| 1 |
- #' Univariate Formula Special Term+ #' Odds Ratio Estimation |
||
| 5 |
- #' The special term `univariate` indicate that the model should be fitted individually for+ #' Compares bivariate responses between two groups in terms of odds ratios |
||
| 6 |
- #' every variable included in univariate.+ #' along with a confidence interval. |
||
| 8 |
- #' @param x A vector of variable name separated by commas.+ #' @inheritParams split_cols_by_groups |
||
| 9 |
- #'+ #' @inheritParams argument_convention |
||
| 10 |
- #' @return When used within a model formula, produces univariate models for each variable provided.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_odds_ratio")`
|
||
| 11 |
- #'+ #' to see available statistics for this function. |
||
| 12 |
- #' @details+ #' |
||
| 13 |
- #' If provided alongside with pairwise specification, the model+ #' @details This function uses either logistic regression for unstratified |
||
| 14 |
- #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models+ #' analyses, or conditional logistic regression for stratified analyses. |
||
| 15 |
- #' + `y ~ ARM`+ #' The Wald confidence interval with the specified confidence level is |
||
| 16 |
- #' + `y ~ ARM + SEX`+ #' calculated. |
||
| 17 |
- #' + `y ~ ARM + AGE`+ #' |
||
| 18 |
- #' + `y ~ ARM + RACE`+ #' @note For stratified analyses, there is currently no implementation for conditional |
||
| 19 |
- #'+ #' likelihood confidence intervals, therefore the likelihood confidence interval is not |
||
| 20 |
- #' @export+ #' yet available as an option. Besides, when `rsp` contains only responders or non-responders, |
||
| 21 |
- univariate <- function(x) {
+ #' then the result values will be `NA`, because no odds ratio estimation is possible. |
||
| 22 | -1x | +
- structure(x, varname = deparse(substitute(x)))+ #' |
|
| 23 |
- }+ #' @seealso Relevant helper function [h_odds_ratio()]. |
||
| 24 |
-
+ #' |
||
| 25 |
- # Get the right-hand-term of a formula+ #' @name odds_ratio |
||
| 26 |
- rht <- function(x) {
+ #' @order 1 |
||
| 27 | -4x | +
- checkmate::assert_formula(x)+ NULL |
|
| 28 | -4x | +
- y <- as.character(rev(x)[[1]])+ |
|
| 29 | -4x | +
- return(y)+ #' @describeIn odds_ratio Statistics function which estimates the odds ratio |
|
| 30 |
- }+ #' between a treatment and a control. A `variables` list with `arm` and `strata` |
||
| 31 |
-
+ #' variable names must be passed if a stratified analysis is required. |
||
| 32 |
- #' Hazard Ratio Estimation in Interactions+ #' |
||
| 33 |
- #'+ #' @return |
||
| 34 |
- #' This function estimates the hazard ratios between arms when an interaction variable is given with+ #' * `s_odds_ratio()` returns a named list with the statistics `or_ci` |
||
| 35 |
- #' specific values.+ #' (containing `est`, `lcl`, and `ucl`) and `n_tot`. |
||
| 37 |
- #' @param variable,given Names of two variable in interaction. We seek the estimation of the levels of `variable`+ #' @examples |
||
| 38 |
- #' given the levels of `given`.+ #' # Unstratified analysis. |
||
| 39 |
- #' @param lvl_var,lvl_given corresponding levels has given by `levels`.+ #' s_odds_ratio( |
||
| 40 |
- #' @param mmat A name numeric filled with 0 used as template to obtain the design matrix.+ #' df = subset(dta, grp == "A"), |
||
| 41 |
- #' @param coef Numeric of estimated coefficients.+ #' .var = "rsp", |
||
| 42 |
- #' @param vcov Variance-covariance matrix of underlying model.+ #' .ref_group = subset(dta, grp == "B"), |
||
| 43 |
- #' @param conf_level Single numeric for the confidence level of estimate intervals.+ #' .in_ref_col = FALSE, |
||
| 44 |
- #'+ #' .df_row = dta |
||
| 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:+ #' # Stratified analysis. |
||
| 48 |
- #'+ #' s_odds_ratio( |
||
| 49 |
- #' - b1 (arm b), b2 (arm c)+ #' df = subset(dta, grp == "A"), |
||
| 50 |
- #' - b3 (sex m)+ #' .var = "rsp", |
||
| 51 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ #' .ref_group = subset(dta, grp == "B"), |
||
| 52 |
- #'+ #' .in_ref_col = FALSE, |
||
| 53 |
- #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation+ #' .df_row = dta, |
||
| 54 |
- #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),+ #' variables = list(arm = "grp", strata = "strata") |
||
| 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 |
- #'+ #' @export |
||
| 58 |
- #' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of+ s_odds_ratio <- function(df, |
||
| 59 |
- #' `variable` and `given`, with columns:+ .var, |
||
| 60 |
- #' * `coef_hat`: Estimation of the coefficient.+ .ref_group, |
||
| 61 |
- #' * `coef_se`: Standard error of the estimation.+ .in_ref_col, |
||
| 62 |
- #' * `hr`: Hazard ratio.+ .df_row, |
||
| 63 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ variables = list(arm = NULL, strata = NULL), |
||
| 64 |
- #'+ conf_level = 0.95, |
||
| 65 |
- #' @seealso [s_cox_multivariate()].+ groups_list = NULL) {
|
||
| 66 | -+ | 70x |
- #'+ y <- list(or_ci = "", n_tot = "") |
| 67 |
- #' @examples+ |
||
| 68 | -+ | 70x |
- #' library(dplyr)+ if (!.in_ref_col) {
|
| 69 | -+ | 70x |
- #' library(survival)+ assert_proportion_value(conf_level) |
| 70 | -+ | 70x |
- #'+ assert_df_with_variables(df, list(rsp = .var)) |
| 71 | -+ | 70x |
- #' ADSL <- tern_ex_adsl %>%+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
| 72 |
- #' filter(SEX %in% c("F", "M"))
+
|
||
| 73 | -+ | 70x |
- #'+ if (is.null(variables$strata)) {
|
| 74 | -+ | 57x |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")+ data <- data.frame( |
| 75 | -+ | 57x |
- #' adtte$ARMCD <- droplevels(adtte$ARMCD)+ rsp = c(.ref_group[[.var]], df[[.var]]), |
| 76 | -+ | 57x |
- #' adtte$SEX <- droplevels(adtte$SEX)+ grp = factor( |
| 77 | -+ | 57x |
- #'+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
| 78 | -+ | 57x |
- #' mod <- coxph(+ levels = c("ref", "Not-ref")
|
| 79 |
- #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,+ ) |
||
| 80 |
- #' data = adtte+ ) |
||
| 81 | -+ | 57x |
- #' )+ y <- or_glm(data, conf_level = conf_level) |
| 82 |
- #'+ } else {
|
||
| 83 | -+ | 13x |
- #' mmat <- stats::model.matrix(mod)[1, ]+ assert_df_with_variables(.df_row, c(list(rsp = .var), variables)) |
| 84 |
- #' mmat[!mmat == 0] <- 0+ |
||
| 85 |
- #'+ # The group variable prepared for clogit must be synchronised with combination groups definition. |
||
| 86 | -+ | 13x |
- #' @keywords internal+ if (is.null(groups_list)) {
|
| 87 | -+ | 12x |
- estimate_coef <- function(variable, given,+ ref_grp <- as.character(unique(.ref_group[[variables$arm]])) |
| 88 | -+ | 12x |
- lvl_var, lvl_given,+ trt_grp <- as.character(unique(df[[variables$arm]])) |
| 89 | -+ | 12x |
- coef,+ grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp) |
| 90 |
- mmat,+ } else {
|
||
| 91 |
- vcov,+ # If more than one level in reference col. |
||
| 92 | -+ | 1x |
- conf_level = 0.95) {
+ reference <- as.character(unique(.ref_group[[variables$arm]])) |
| 93 | -8x | +1x |
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ grp_ref_flag <- vapply( |
| 94 | -8x | +1x |
- giv_lvl <- paste0(given, lvl_given)+ X = groups_list, |
| 95 | -+ | 1x |
-
+ FUN.VALUE = TRUE, |
| 96 | -8x | +1x |
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ FUN = function(x) all(reference %in% x) |
| 97 | -8x | +
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ ) |
|
| 98 | -8x | +1x |
- design_mat <- within(+ ref_grp <- names(groups_list)[grp_ref_flag] |
| 99 | -8x | +
- data = design_mat,+ |
|
| 100 | -8x | +
- expr = {
+ # If more than one level in treatment col. |
|
| 101 | -8x | +1x |
- inter <- paste0(variable, ":", given)+ treatment <- as.character(unique(df[[variables$arm]])) |
| 102 | -8x | +1x |
- rev_inter <- paste0(given, ":", variable)+ grp_trt_flag <- vapply( |
| 103 | -+ | 1x |
- }+ X = groups_list, |
| 104 | -+ | 1x |
- )+ FUN.VALUE = TRUE, |
| 105 | -+ | 1x |
-
+ FUN = function(x) all(treatment %in% x) |
| 106 | -8x | +
- split_by_variable <- design_mat$variable+ ) |
|
| 107 | -8x | +1x |
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ trt_grp <- names(groups_list)[grp_trt_flag] |
| 109 | -8x | +1x |
- design_mat <- apply(+ grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp) |
| 110 | -8x | +1x |
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ grp <- combine_levels(grp, levels = treatment, new_level = trt_grp) |
| 111 | -27x | +
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ } |
|
| 112 | -27x | +
- return(mmat)+ |
|
| 113 |
- }+ # The reference level in `grp` must be the same as in the `rtables` column split. |
||
| 114 | -+ | 13x |
- )+ data <- data.frame( |
| 115 | -8x | +13x |
- colnames(design_mat) <- interaction_names+ rsp = .df_row[[.var]], |
| 116 | -+ | 13x |
-
+ grp = grp, |
| 117 | -8x | +13x |
- betas <- as.matrix(coef)+ strata = interaction(.df_row[variables$strata]) |
| 118 |
-
+ ) |
||
| 119 | -8x | +13x |
- coef_hat <- t(design_mat) %*% betas+ y_all <- or_clogit(data, conf_level = conf_level) |
| 120 | -8x | +13x |
- dimnames(coef_hat)[2] <- "coef"+ checkmate::assert_string(trt_grp) |
| 121 | -+ | 13x |
-
+ checkmate::assert_subset(trt_grp, names(y_all$or_ci)) |
| 122 | -8x | +12x |
- coef_se <- apply(design_mat, 2, function(x) {
+ y$or_ci <- y_all$or_ci[[trt_grp]] |
| 123 | -27x | +12x |
- vcov_el <- as.logical(x)+ y$n_tot <- y_all$n_tot |
| 124 | -27x | +
- y <- vcov[vcov_el, vcov_el]+ } |
|
| 125 | -27x | +
- y <- sum(y)+ } |
|
| 126 | -27x | +
- y <- sqrt(y)+ |
|
| 127 | -27x | +69x |
- return(y)+ y$or_ci <- formatters::with_label( |
| 128 | -+ | 69x |
- })+ x = y$or_ci, |
| 129 | -+ | 69x |
-
+ label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
|
| 130 | -8x | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ ) |
|
| 131 | -8x | +
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ |
|
| 132 | -+ | 69x |
-
+ y$n_tot <- formatters::with_label( |
| 133 | -8x | +69x |
- y <- apply(y, 1, function(x) {
+ x = y$n_tot, |
| 134 | -27x | +69x |
- x["hr"] <- exp(x["coef"])+ label = "Total n" |
| 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 | -+ | 69x |
-
+ y |
| 138 | -27x | +
- return(x)+ } |
|
| 139 |
- })+ |
||
| 140 |
-
+ #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`. |
||
| 141 | -8x | +
- y <- t(y)+ #' |
|
| 142 | -8x | +
- y <- by(y, split_by_variable, identity)+ #' @return |
|
| 143 | -8x | +
- y <- lapply(y, as.matrix)+ #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 144 |
-
+ #' |
||
| 145 | -8x | +
- attr(y, "details") <- paste0(+ #' @examples |
|
| 146 | -8x | +
- "Estimations of ", variable,+ #' a_odds_ratio( |
|
| 147 | -8x | +
- " hazard ratio given the level of ", given, " compared to ",+ #' df = subset(dta, grp == "A"), |
|
| 148 | -8x | +
- variable, " level ", lvl_var[1], "."+ #' .var = "rsp", |
|
| 149 |
- )+ #' .ref_group = subset(dta, grp == "B"), |
||
| 150 | -8x | +
- return(y)+ #' .in_ref_col = FALSE, |
|
| 151 |
- }+ #' .df_row = dta |
||
| 152 |
-
+ #' ) |
||
| 153 |
- #' `tryCatch` around `car::Anova`+ #' |
||
| 154 |
- #'+ #' @export |
||
| 155 |
- #' Captures warnings when executing [car::Anova].+ a_odds_ratio <- make_afun( |
||
| 156 |
- #'+ s_odds_ratio, |
||
| 157 |
- #' @inheritParams car::Anova+ .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"), |
||
| 158 |
- #'+ .indent_mods = c(or_ci = 1L) |
||
| 159 |
- #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings.+ ) |
||
| 160 |
- #'+ |
||
| 161 |
- #' @examples+ #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments |
||
| 162 |
- #' # `car::Anova` on cox regression model including strata and expected+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 163 |
- #' # a likelihood ratio test triggers a warning as only `Wald` method is+ #' |
||
| 164 |
- #' # accepted.+ #' @param ... arguments passed to `s_odds_ratio()`. |
||
| 166 |
- #' library(survival)+ #' @return |
||
| 167 |
- #'+ #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions, |
||
| 168 |
- #' mod <- coxph(+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 169 |
- #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),+ #' the statistics from `s_odds_ratio()` to the table layout. |
||
| 170 |
- #' data = ovarian+ #' |
||
| 171 |
- #' )+ #' @examples |
||
| 172 |
- #'+ #' set.seed(12) |
||
| 173 |
- #' @keywords internal+ #' dta <- data.frame( |
||
| 174 |
- try_car_anova <- function(mod,+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 175 |
- test.statistic) { # nolint
+ #' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
|
||
| 176 | -2x | +
- y <- tryCatch(+ #' strata = factor(sample(c("C", "D"), 100, TRUE))
|
|
| 177 | -2x | +
- withCallingHandlers(+ #' ) |
|
| 178 | -2x | +
- expr = {
+ #' |
|
| 179 | -2x | +
- warn_text <- c()+ #' l <- basic_table() %>% |
|
| 180 | -2x | +
- list(+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
|
| 181 | -2x | +
- aov = car::Anova(+ #' estimate_odds_ratio(vars = "rsp") |
|
| 182 | -2x | +
- mod,+ #' |
|
| 183 | -2x | +
- test.statistic = test.statistic,+ #' build_table(l, df = dta) |
|
| 184 | -2x | +
- type = "III"+ #' |
|
| 185 |
- ),+ #' @export |
||
| 186 | -2x | +
- warn_text = warn_text+ #' @order 2 |
|
| 187 |
- )+ estimate_odds_ratio <- function(lyt, |
||
| 188 |
- },+ vars, |
||
| 189 | -2x | +
- warning = function(w) {
+ variables = list(arm = NULL, strata = NULL), |
|
| 190 |
- # If a warning is detected it is handled as "w".+ conf_level = 0.95, |
||
| 191 | -! | +
- warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
+ groups_list = NULL, |
|
| 192 |
-
+ na_str = default_na_str(), |
||
| 193 |
- # A warning is sometimes expected, then, we want to restart+ nested = TRUE, |
||
| 194 |
- # the execution while ignoring the warning.+ ..., |
||
| 195 | -! | +
- invokeRestart("muffleWarning")
+ show_labels = "hidden", |
|
| 196 |
- }+ table_names = vars, |
||
| 197 |
- ),+ .stats = "or_ci", |
||
| 198 | -2x | +
- finally = {
+ .formats = NULL, |
|
| 199 |
- }+ .labels = NULL, |
||
| 200 |
- )+ .indent_mods = NULL) {
|
||
| 201 | -+ | 4x |
-
+ extra_args <- list(variables = variables, conf_level = conf_level, groups_list = groups_list, ...) |
| 202 | -2x | +
- return(y)+ |
|
| 203 | -+ | 4x |
- }+ afun <- make_afun( |
| 204 | -+ | 4x |
-
+ a_odds_ratio, |
| 205 | -+ | 4x |
- #' Fit the Cox Regression Model and `Anova`+ .stats = .stats, |
| 206 | -+ | 4x |
- #'+ .formats = .formats, |
| 207 | -+ | 4x |
- #' The functions allows to derive from the [survival::coxph()] results the effect p.values using [car::Anova()].+ .labels = .labels, |
| 208 | -+ | 4x |
- #' This last package introduces more flexibility to get the effect p.values.+ .indent_mods = .indent_mods |
| 209 |
- #'+ ) |
||
| 210 |
- #' @inheritParams t_coxreg+ |
||
| 211 | -+ | 4x |
- #'+ analyze( |
| 212 | -+ | 4x |
- #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and+ lyt, |
| 213 | -+ | 4x |
- #' `aov` (result of [car::Anova()]).+ vars, |
| 214 | -+ | 4x |
- #'+ afun = afun, |
| 215 | -+ | 4x |
- #' @noRd+ na_str = na_str, |
| 216 | -+ | 4x |
- fit_n_aov <- function(formula,+ nested = nested, |
| 217 | -+ | 4x |
- data = data,+ extra_args = extra_args, |
| 218 | -+ | 4x |
- conf_level = conf_level,+ show_labels = show_labels, |
| 219 | -+ | 4x |
- pval_method = c("wald", "likelihood"),
+ table_names = table_names |
| 220 |
- ...) {
+ ) |
||
| 221 | -1x | +
- pval_method <- match.arg(pval_method)+ } |
|
| 223 | -1x | +
- environment(formula) <- environment()+ #' Helper Functions for Odds Ratio Estimation |
|
| 224 | -1x | +
- suppressWarnings({
+ #' |
|
| 225 |
- # We expect some warnings due to coxph which fails strict programming.+ #' @description `r lifecycle::badge("stable")`
|
||
| 226 | -1x | +
- mod <- survival::coxph(formula, data = data, ...)+ #' |
|
| 227 | -1x | +
- msum <- summary(mod, conf.int = conf_level)+ #' Functions to calculate odds ratios in [estimate_odds_ratio()]. |
|
| 228 |
- })+ #' |
||
| 229 |
-
+ #' @inheritParams argument_convention |
||
| 230 | -1x | +
- aov <- try_car_anova(+ #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally |
|
| 231 | -1x | +
- mod,+ #' `strata` for [or_clogit()]. |
|
| 232 | -1x | +
- test.statistic = switch(pval_method,+ #' |
|
| 233 | -1x | +
- "wald" = "Wald",+ #' @return A named `list` of elements `or_ci` and `n_tot`. |
|
| 234 | -1x | +
- "likelihood" = "LR"+ #' |
|
| 235 |
- )+ #' @seealso [odds_ratio] |
||
| 236 |
- )+ #' |
||
| 237 |
-
+ #' @name h_odds_ratio |
||
| 238 | -1x | +
- warn_attr <- aov$warn_text+ NULL |
|
| 239 | -! | +
- if (!is.null(aov$warn_text)) message(warn_attr)+ |
|
| 240 |
-
+ #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be |
||
| 241 | -1x | +
- aov <- aov$aov+ #' exactly 2 groups in `data` as specified by the `grp` variable. |
|
| 242 | -1x | +
- y <- list(mod = mod, msum = msum, aov = aov)+ #' |
|
| 243 | -1x | +
- attr(y, "message") <- warn_attr+ #' @examples |
|
| 244 |
-
+ #' # Data with 2 groups. |
||
| 245 | -1x | +
- return(y)+ #' data <- data.frame( |
|
| 246 |
- }+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)), |
||
| 247 |
-
+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)], |
||
| 248 |
- # argument_checks+ #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)], |
||
| 249 |
- check_formula <- function(formula) {
+ #' stringsAsFactors = TRUE |
||
| 250 | -1x | +
- if (!(inherits(formula, "formula"))) {
+ #' ) |
|
| 251 | -1x | +
- stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
+ #' |
|
| 252 |
- }+ #' # Odds ratio based on glm. |
||
| 253 |
-
+ #' or_glm(data, conf_level = 0.95) |
||
| 254 | -! | +
- invisible()+ #' |
|
| 255 |
- }+ #' @export |
||
| 256 |
-
+ or_glm <- function(data, conf_level) {
|
||
| 257 | -+ | 62x |
- check_covariate_formulas <- function(covariates) {
+ checkmate::assert_logical(data$rsp) |
| 258 | -1x | +62x |
- if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
+ assert_proportion_value(conf_level) |
| 259 | -1x | +62x |
- stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp")) |
| 260 | -+ | 62x |
- }+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
| 262 | -! | +62x |
- invisible()+ data$grp <- as_factor_keep_attributes(data$grp) |
| 263 | -+ | 62x |
- }+ assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2) |
| 264 | -+ | 62x |
-
+ formula <- stats::as.formula("rsp ~ grp")
|
| 265 | -+ | 62x |
- name_covariate_names <- function(covariates) {
+ model_fit <- stats::glm( |
| 266 | -1x | +62x |
- miss_names <- names(covariates) == ""+ formula = formula, data = data, |
| 267 | -1x | +62x |
- no_names <- is.null(names(covariates))+ family = stats::binomial(link = "logit") |
| 268 | -! | +
- if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")+ ) |
|
| 269 | -! | +
- if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ |
|
| 270 | -1x | +
- return(covariates)+ # Note that here we need to discard the intercept. |
|
| 271 | -+ | 62x |
- }+ or <- exp(stats::coef(model_fit)[-1]) |
| 272 | -+ | 62x |
-
+ or_ci <- exp( |
| 273 | -+ | 62x |
- check_increments <- function(increments, covariates) {
+ stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE] |
| 274 | -1x | +
- if (!is.null(increments)) {
+ ) |
|
| 275 | -1x | +
- covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ |
|
| 276 | -1x | +62x |
- lapply(+ values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
|
| 277 | -1x | +62x |
- X = names(increments), FUN = function(x) {
+ n_tot <- stats::setNames(nrow(model_fit$model), "n_tot") |
| 278 | -3x | +
- if (!x %in% covariates) {
+
|
|
| 279 | -1x | +62x |
- warning(+ list(or_ci = values, n_tot = n_tot) |
| 280 | -1x | +
- paste(+ } |
|
| 281 | -1x | +
- "Check `increments`, the `increment` for ", x,+ |
|
| 282 | -1x | +
- "doesn't match any names in investigated covariate(s)."+ #' @describeIn h_odds_ratio estimates the odds ratio based on [survival::clogit()]. This is done for |
|
| 283 |
- )+ #' the whole data set including all groups, since the results are not the same as when doing |
||
| 284 |
- )+ #' pairwise comparisons between the groups. |
||
| 285 |
- }+ #' |
||
| 286 |
- }+ #' @examples |
||
| 287 |
- )+ #' # Data with 3 groups. |
||
| 288 |
- }+ #' data <- data.frame( |
||
| 289 |
-
+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)), |
||
| 290 | -1x | +
- invisible()+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)], |
|
| 291 |
- }+ #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)], |
||
| 292 |
-
+ #' stringsAsFactors = TRUE |
||
| 293 |
- #' Multivariate Cox Model - Summarized Results+ #' ) |
||
| 295 |
- #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or+ #' # Odds ratio based on stratified estimation by conditional logistic regression. |
||
| 296 |
- #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually+ #' or_clogit(data, conf_level = 0.95) |
||
| 297 |
- #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the+ #' |
||
| 298 |
- #' covariates included in the model.+ #' @export |
||
| 299 |
- #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the+ or_clogit <- function(data, conf_level) {
|
||
| 300 | -+ | 16x |
- #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,+ checkmate::assert_logical(data$rsp) |
| 301 | -+ | 16x |
- #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,+ assert_proportion_value(conf_level) |
| 302 | -+ | 16x |
- #' `NEST's bookdown`)+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata")) |
| 303 | -+ | 16x |
- #'+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
| 304 | -+ | 16x |
- #' @param formula (`formula`)\cr A formula corresponding to the investigated [survival::Surv()] survival model+ checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
|
| 305 |
- #' including covariates.+ |
||
| 306 | -+ | 16x |
- #' @param data (`data.frame`)\cr A data frame which includes the variable in formula and covariates.+ data$grp <- as_factor_keep_attributes(data$grp) |
| 307 | -+ | 16x |
- #' @param conf_level (`proportion`)\cr The confidence level for the hazard ratio interval estimations. Default is 0.95.+ data$strata <- as_factor_keep_attributes(data$strata) |
| 308 |
- #' @param pval_method (`character`)\cr The method used for the estimation of p-values, should be one of+ |
||
| 309 |
- #' `"wald"` (default) or `"likelihood"`.+ # Deviation from convention: `survival::strata` must be simply `strata`. |
||
| 310 | -+ | 16x |
- #' @param ... Optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the+ formula <- stats::as.formula("rsp ~ grp + strata(strata)")
|
| 311 | -+ | 16x |
- #' method for tie handling, one of `exact` (default), `efron`, `breslow`.+ model_fit <- clogit_with_tryCatch(formula = formula, data = data) |
| 312 |
- #'+ |
||
| 313 |
- #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`.+ # Create a list with one set of OR estimates and CI per coefficient, i.e. |
||
| 314 |
- #'+ # comparison of one group vs. the reference group. |
||
| 315 | -+ | 16x |
- #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms+ coef_est <- stats::coef(model_fit) |
| 316 | -+ | 16x |
- #' but is out of scope as defined by the Global Data Standards Repository+ ci_est <- stats::confint(model_fit, level = conf_level) |
| 317 | -+ | 16x |
- #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).+ or_ci <- list() |
| 318 | -+ | 16x |
- #'+ for (coef_name in names(coef_est)) {
|
| 319 | -+ | 18x |
- #' @seealso [estimate_coef()].+ grp_name <- gsub("^grp", "", x = coef_name)
|
| 320 | -+ | 18x |
- #'+ or_ci[[grp_name]] <- stats::setNames( |
| 321 | -+ | 18x |
- #' @examples+ object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), |
| 322 | -+ | 18x |
- #' library(dplyr)+ nm = c("est", "lcl", "ucl")
|
| 323 |
- #'+ ) |
||
| 324 |
- #' adtte <- tern_ex_adtte+ } |
||
| 325 | -+ | 16x |
- #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered+ list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n)) |
| 326 |
- #' adtte_f <- filter(+ } |
| 327 | +1 |
- #' adtte_f,+ #' Univariate Formula Special Term |
||
| 328 | +2 |
- #' PARAMCD == "OS" &+ #' |
||
| 329 | +3 |
- #' SEX %in% c("F", "M") &
+ #' @description `r lifecycle::badge("stable")`
|
||
| 330 | +4 |
- #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
+ #' |
||
| 331 | +5 |
- #' )+ #' The special term `univariate` indicate that the model should be fitted individually for |
||
| 332 | +6 |
- #' adtte_f$SEX <- droplevels(adtte_f$SEX)+ #' every variable included in univariate. |
||
| 333 | +7 |
- #' adtte_f$RACE <- droplevels(adtte_f$RACE)+ #' |
||
| 334 | +8 |
- #'+ #' @param x A vector of variable name separated by commas. |
||
| 335 | +9 |
- #' @keywords internal+ #' |
||
| 336 | +10 |
- s_cox_multivariate <- function(formula, data,+ #' @return When used within a model formula, produces univariate models for each variable provided. |
||
| 337 | +11 |
- conf_level = 0.95,+ #' |
||
| 338 | +12 |
- pval_method = c("wald", "likelihood"),
+ #' @details |
||
| 339 | +13 |
- ...) {
- |
- ||
| 340 | -1x | -
- tf <- stats::terms(formula, specials = c("strata"))
- |
- ||
| 341 | -1x | -
- covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]- |
- ||
| 342 | -1x | -
- lapply(- |
- ||
| 343 | -1x | -
- X = covariates,- |
- ||
| 344 | -1x | -
- FUN = function(x) {
- |
- ||
| 345 | -3x | -
- if (is.character(data[[x]])) {
- |
- ||
| 346 | -1x | -
- data[[x]] <<- as.factor(data[[x]])+ #' If provided alongside with pairwise specification, the model |
||
| 347 | +14 |
- }- |
- ||
| 348 | -3x | -
- invisible()+ #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models |
||
| 349 | +15 |
- }+ #' + `y ~ ARM` |
||
| 350 | +16 |
- )- |
- ||
| 351 | -1x | -
- pval_method <- match.arg(pval_method)+ #' + `y ~ ARM + SEX` |
||
| 352 | +17 |
-
+ #' + `y ~ ARM + AGE` |
||
| 353 | +18 |
- # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)- |
- ||
| 354 | -1x | -
- y <- fit_n_aov(- |
- ||
| 355 | -1x | -
- formula = formula,- |
- ||
| 356 | -1x | -
- data = data,- |
- ||
| 357 | -1x | -
- conf_level = conf_level,- |
- ||
| 358 | -1x | -
- pval_method = pval_method,+ #' + `y ~ ARM + RACE` |
||
| 359 | +19 |
- ...+ #' |
||
| 360 | +20 |
- )- |
- ||
| 361 | -1x | -
- mod <- y$mod- |
- ||
| 362 | -1x | -
- aov <- y$aov- |
- ||
| 363 | -1x | -
- msum <- y$msum- |
- ||
| 364 | -1x | -
- list2env(as.list(y), environment())+ #' @export |
||
| 365 | +21 | - - | -||
| 366 | -1x | -
- all_term_labs <- attr(mod$terms, "term.labels")+ univariate <- function(x) {
|
||
| 367 | +22 | 1x |
- term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]+ structure(x, varname = deparse(substitute(x))) |
|
| 368 | -1x | +|||
| 23 | +
- names(term_labs) <- term_labs+ } |
|||
| 369 | +24 | |||
| 370 | -1x | -
- coef_inter <- NULL- |
- ||
| 371 | -1x | -
- if (any(attr(mod$terms, "order") > 1)) {
- |
- ||
| 372 | -1x | +|||
| 25 | +
- for_inter <- all_term_labs[attr(mod$terms, "order") > 1]+ # Get the right-hand-term of a formula |
|||
| 373 | -1x | +|||
| 26 | +
- names(for_inter) <- for_inter+ rht <- function(x) {
|
|||
| 374 | -1x | +27 | +4x |
- mmat <- stats::model.matrix(mod)[1, ]+ checkmate::assert_formula(x) |
| 375 | -1x | +28 | +4x |
- mmat[!mmat == 0] <- 0+ y <- as.character(rev(x)[[1]]) |
| 376 | -1x | +29 | +4x |
- mcoef <- stats::coef(mod)+ return(y) |
| 377 | -1x | +|||
| 30 | +
- mvcov <- stats::vcov(mod)+ } |
|||
| 378 | +31 | |||
| 379 | -1x | -
- estimate_coef_local <- function(variable, given) {
- |
- ||
| 380 | -6x | -
- estimate_coef(- |
- ||
| 381 | -6x | -
- variable, given,- |
- ||
| 382 | -6x | -
- coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,- |
- ||
| 383 | -6x | -
- lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])- |
- ||
| 384 | +32 |
- )+ #' Hazard Ratio Estimation in Interactions |
||
| 385 | +33 |
- }+ #' |
||
| 386 | +34 |
-
+ #' This function estimates the hazard ratios between arms when an interaction variable is given with |
||
| 387 | -1x | +|||
| 35 | +
- coef_inter <- lapply(+ #' specific values. |
|||
| 388 | -1x | +|||
| 36 | +
- for_inter, function(x) {
+ #' |
|||
| 389 | -3x | +|||
| 37 | +
- y <- attr(mod$terms, "factor")[, x]+ #' @param variable,given Names of two variable in interaction. We seek the estimation of the levels of `variable` |
|||
| 390 | -3x | +|||
| 38 | +
- y <- names(y[y > 0])+ #' given the levels of `given`. |
|||
| 391 | -3x | +|||
| 39 | +
- Map(estimate_coef_local, variable = y, given = rev(y))+ #' @param lvl_var,lvl_given corresponding levels has given by `levels`. |
|||
| 392 | +40 |
- }+ #' @param mmat A name numeric filled with 0 used as template to obtain the design matrix. |
||
| 393 | +41 |
- )+ #' @param coef Numeric of estimated coefficients. |
||
| 394 | +42 |
- }+ #' @param vcov Variance-covariance matrix of underlying model. |
||
| 395 | +43 |
-
+ #' @param conf_level Single numeric for the confidence level of estimate intervals. |
||
| 396 | -1x | +|||
| 44 | +
- list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)+ #' |
|||
| 397 | +45 |
- }+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
| 1 | +46 |
- #' Confidence Interval for Mean+ #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex. |
||
| 2 | +47 |
- #'+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 3 | +48 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 | +49 |
- #'+ #' - b1 (arm b), b2 (arm c) |
||
| 5 | +50 |
- #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the+ #' - b3 (sex m) |
||
| 6 | +51 |
- #' geometric mean. It can be used as a `ggplot` helper function for plotting.+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 7 | +52 |
#' |
||
| 8 | +53 |
- #' @inheritParams argument_convention+ #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation |
||
| 9 | +54 |
- #' @param n_min (`number`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean.+ #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5), |
||
| 10 | +55 |
- #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`.+ #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained |
||
| 11 | +56 |
- #' @param geom_mean (`logical`)\cr `TRUE` when the geometric mean should be calculated.+ #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95. |
||
| 12 | +57 |
#' |
||
| 13 | +58 |
- #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`.+ #' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of |
||
| 14 | +59 |
- #'+ #' `variable` and `given`, with columns: |
||
| 15 | +60 |
- #' @examples+ #' * `coef_hat`: Estimation of the coefficient. |
||
| 16 | +61 |
- #' stat_mean_ci(sample(10), gg_helper = FALSE)+ #' * `coef_se`: Standard error of the estimation. |
||
| 17 | +62 |
- #'+ #' * `hr`: Hazard ratio. |
||
| 18 | +63 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
||
| 19 | +64 |
- #' ggplot2::geom_point()+ #' |
||
| 20 | +65 |
- #'+ #' @seealso [s_cox_multivariate()]. |
||
| 21 | +66 |
- #' p + ggplot2::stat_summary(+ #' |
||
| 22 | +67 |
- #' fun.data = stat_mean_ci,+ #' @examples |
||
| 23 | +68 |
- #' geom = "errorbar"+ #' library(dplyr) |
||
| 24 | +69 |
- #' )+ #' library(survival) |
||
| 25 | +70 |
#' |
||
| 26 | +71 |
- #' p + ggplot2::stat_summary(+ #' ADSL <- tern_ex_adsl %>% |
||
| 27 | +72 |
- #' fun.data = stat_mean_ci,+ #' filter(SEX %in% c("F", "M"))
|
||
| 28 | +73 |
- #' fun.args = list(conf_level = 0.5),+ #' |
||
| 29 | +74 |
- #' geom = "errorbar"+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS") |
||
| 30 | +75 |
- #' )+ #' adtte$ARMCD <- droplevels(adtte$ARMCD) |
||
| 31 | +76 |
- #'+ #' adtte$SEX <- droplevels(adtte$SEX) |
||
| 32 | +77 |
- #' p + ggplot2::stat_summary(+ #' |
||
| 33 | +78 |
- #' fun.data = stat_mean_ci,+ #' mod <- coxph( |
||
| 34 | +79 |
- #' fun.args = list(conf_level = 0.5, geom_mean = TRUE),+ #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2, |
||
| 35 | +80 |
- #' geom = "errorbar"+ #' data = adtte |
||
| 36 | +81 |
#' ) |
||
| 37 | +82 |
#' |
||
| 38 | +83 |
- #' @export+ #' mmat <- stats::model.matrix(mod)[1, ] |
||
| 39 | +84 |
- stat_mean_ci <- function(x,+ #' mmat[!mmat == 0] <- 0 |
||
| 40 | +85 |
- conf_level = 0.95,+ #' |
||
| 41 | +86 |
- na.rm = TRUE, # nolint+ #' @keywords internal |
||
| 42 | +87 |
- n_min = 2,+ estimate_coef <- function(variable, given, |
||
| 43 | +88 |
- gg_helper = TRUE,+ lvl_var, lvl_given, |
||
| 44 | +89 |
- geom_mean = FALSE) {
- |
- ||
| 45 | -720x | -
- if (na.rm) {
- |
- ||
| 46 | -2x | -
- x <- stats::na.omit(x)+ coef, |
||
| 47 | +90 |
- }+ mmat, |
||
| 48 | -720x | +|||
| 91 | +
- n <- length(x)+ vcov, |
|||
| 49 | +92 |
-
+ conf_level = 0.95) {
|
||
| 50 | -720x | +93 | +8x |
- if (!geom_mean) {
+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
| 51 | -361x | +94 | +8x |
- m <- mean(x)+ giv_lvl <- paste0(given, lvl_given) |
| 52 | +95 |
- } else {
+
|
||
| 53 | -359x | +96 | +8x |
- negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0)+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
| 54 | -359x | +97 | +8x |
- if (negative_values_exist) {
+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 55 | -22x | +98 | +8x |
- m <- NA_real_+ design_mat <- within( |
| 56 | -+ | |||
| 99 | +8x |
- } else {
+ data = design_mat, |
||
| 57 | -337x | +100 | +8x |
- x <- log(x)+ expr = {
|
| 58 | -337x | +101 | +8x |
- m <- mean(x)+ inter <- paste0(variable, ":", given)+ |
+
| 102 | +8x | +
+ rev_inter <- paste0(given, ":", variable) |
||
| 59 | +103 |
} |
||
| 60 | +104 |
- }+ ) |
||
| 61 | +105 | |||
| 62 | -720x | +106 | +8x |
- if (n < n_min || is.na(m)) {
+ split_by_variable <- design_mat$variable |
| 63 | -122x | +107 | +8x |
- ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_)+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
| 64 | +108 |
- } else {
+
|
||
| 65 | -598x | +109 | +8x |
- hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n)+ design_mat <- apply( |
| 66 | -598x | +110 | +8x |
- ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci)+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
| 67 | -598x | +111 | +27x |
- if (geom_mean) {
+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
| 68 | -291x | +112 | +27x |
- ci <- exp(ci)+ return(mmat) |
| 69 | +113 |
} |
||
| 70 | +114 |
- }+ )+ |
+ ||
| 115 | +8x | +
+ colnames(design_mat) <- interaction_names |
||
| 71 | +116 | |||
| 72 | -720x | +117 | +8x |
- if (gg_helper) {
+ betas <- as.matrix(coef) |
| 73 | -! | +|||
| 118 | +
- m <- ifelse(is.na(m), NA_real_, m)+ |
|||
| 74 | -! | +|||
| 119 | +8x |
- ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]])+ coef_hat <- t(design_mat) %*% betas |
||
| 75 | -+ | |||
| 120 | +8x |
- }+ dimnames(coef_hat)[2] <- "coef" |
||
| 76 | +121 | |||
| 77 | -720x | +122 | +8x |
- return(ci)+ coef_se <- apply(design_mat, 2, function(x) {
|
| 78 | -+ | |||
| 123 | +27x |
- }+ vcov_el <- as.logical(x) |
||
| 79 | -+ | |||
| 124 | +27x |
-
+ y <- vcov[vcov_el, vcov_el] |
||
| 80 | -+ | |||
| 125 | +27x |
- #' Confidence Interval for Median+ y <- sum(y) |
||
| 81 | -+ | |||
| 126 | +27x |
- #'+ y <- sqrt(y) |
||
| 82 | -+ | |||
| 127 | +27x |
- #' @description `r lifecycle::badge("stable")`
+ return(y) |
||
| 83 | +128 |
- #'+ }) |
||
| 84 | +129 |
- #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper+ |
||
| 85 | -+ | |||
| 130 | +8x |
- #' function for plotting.+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
||
| 86 | -+ | |||
| 131 | +8x |
- #'+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
||
| 87 | +132 |
- #' @inheritParams argument_convention+ |
||
| 88 | -+ | |||
| 133 | +8x |
- #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`.+ 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)"]) |
||
| 89 | +137 |
- #'+ + |
+ ||
| 138 | +27x | +
+ return(x) |
||
| 90 | +139 |
- #' @details The function was adapted from `DescTools/versions/0.99.35/source`+ }) |
||
| 91 | +140 |
- #'+ + |
+ ||
| 141 | +8x | +
+ y <- t(y)+ |
+ ||
| 142 | +8x | +
+ y <- by(y, split_by_variable, identity)+ |
+ ||
| 143 | +8x | +
+ y <- lapply(y, as.matrix) |
||
| 92 | +144 |
- #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`.+ + |
+ ||
| 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], "." |
||
| 93 | +149 |
- #'+ )+ |
+ ||
| 150 | +8x | +
+ return(y) |
||
| 94 | +151 |
- #' @examples+ } |
||
| 95 | +152 |
- #' stat_median_ci(sample(10), gg_helper = FALSE)+ |
||
| 96 | +153 |
- #'+ #' `tryCatch` around `car::Anova` |
||
| 97 | +154 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ #' |
||
| 98 | +155 |
- #' ggplot2::geom_point()+ #' Captures warnings when executing [car::Anova]. |
||
| 99 | +156 |
- #' p + ggplot2::stat_summary(+ #' |
||
| 100 | +157 |
- #' fun.data = stat_median_ci,+ #' @inheritParams car::Anova |
||
| 101 | +158 |
- #' geom = "errorbar"+ #' |
||
| 102 | +159 |
- #' )+ #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings. |
||
| 103 | +160 |
#' |
||
| 104 | +161 |
- #' @export+ #' @examples |
||
| 105 | +162 |
- stat_median_ci <- function(x,+ #' # `car::Anova` on cox regression model including strata and expected |
||
| 106 | +163 |
- conf_level = 0.95,+ #' # a likelihood ratio test triggers a warning as only `Wald` method is |
||
| 107 | +164 |
- na.rm = TRUE, # nolint+ #' # accepted. |
||
| 108 | +165 |
- gg_helper = TRUE) {
+ #' |
||
| 109 | -362x | +|||
| 166 | +
- x <- unname(x)+ #' library(survival) |
|||
| 110 | -362x | +|||
| 167 | +
- if (na.rm) {
+ #' |
|||
| 111 | -3x | +|||
| 168 | +
- x <- x[!is.na(x)]+ #' mod <- coxph( |
|||
| 112 | +169 |
- }+ #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps), |
||
| 113 | -362x | +|||
| 170 | +
- n <- length(x)+ #' data = ovarian |
|||
| 114 | -362x | +|||
| 171 | +
- med <- stats::median(x)+ #' ) |
|||
| 115 | +172 |
-
+ #' |
||
| 116 | -362x | +|||
| 173 | +
- k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE)+ #' @keywords internal |
|||
| 117 | +174 |
-
+ try_car_anova <- function(mod, |
||
| 118 | +175 |
- # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range+ test.statistic) { # nolint
|
||
| 119 | -362x | +176 | +2x |
- if (k == 0 || is.na(med)) {
+ y <- tryCatch( |
| 120 | -98x | +177 | +2x |
- ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)+ withCallingHandlers( |
| 121 | -98x | +178 | +2x |
- empir_conf_level <- NA_real_+ expr = {
|
| 122 | -+ | |||
| 179 | +2x |
- } else {
+ warn_text <- c() |
||
| 123 | -264x | +180 | +2x |
- x_sort <- sort(x)+ list( |
| 124 | -264x | +181 | +2x |
- ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])+ aov = car::Anova( |
| 125 | -264x | +182 | +2x |
- empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5)+ mod, |
| 126 | -+ | |||
| 183 | +2x |
- }+ test.statistic = test.statistic, |
||
| 127 | -+ | |||
| 184 | +2x |
-
+ type = "III" |
||
| 128 | -362x | +|||
| 185 | +
- if (gg_helper) {
+ ), |
|||
| 129 | -! | +|||
| 186 | +2x |
- ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]])+ warn_text = warn_text |
||
| 130 | +187 |
- }+ ) |
||
| 131 | +188 |
-
+ }, |
||
| 132 | -362x | +189 | +2x |
- attr(ci, "conf_level") <- empir_conf_level+ warning = function(w) {
|
| 133 | +190 |
-
+ # If a warning is detected it is handled as "w". |
||
| 134 | -362x | +|||
| 191 | +! |
- return(ci)+ warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
|
||
| 135 | +192 |
- }+ |
||
| 136 | +193 |
-
+ # A warning is sometimes expected, then, we want to restart |
||
| 137 | +194 |
- #' p-Value of the Mean+ # the execution while ignoring the warning. |
||
| 138 | -+ | |||
| 195 | +! |
- #'+ invokeRestart("muffleWarning")
|
||
| 139 | +196 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 140 | +197 |
- #'+ ), |
||
| 141 | -+ | |||
| 198 | +2x |
- #' Convenient function for calculating the two-sided p-value of the mean.+ finally = {
|
||
| 142 | +199 |
- #'+ } |
||
| 143 | +200 |
- #' @inheritParams argument_convention+ ) |
||
| 144 | +201 |
- #' @param n_min (`numeric`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean.+ + |
+ ||
| 202 | +2x | +
+ return(y) |
||
| 145 | +203 |
- #' @param test_mean (`numeric`)\cr mean value to test under the null hypothesis.+ } |
||
| 146 | +204 |
- #'+ |
||
| 147 | +205 |
- #' @return A p-value.+ #' Fit the Cox Regression Model and `Anova` |
||
| 148 | +206 |
#' |
||
| 149 | +207 |
- #' @examples+ #' The functions allows to derive from the [survival::coxph()] results the effect p.values using [car::Anova()]. |
||
| 150 | +208 |
- #' stat_mean_pval(sample(10))+ #' This last package introduces more flexibility to get the effect p.values. |
||
| 151 | +209 |
#' |
||
| 152 | +210 |
- #' stat_mean_pval(rnorm(10), test_mean = 0.5)+ #' @inheritParams t_coxreg |
||
| 153 | +211 |
#' |
||
| 154 | +212 |
- #' @export+ #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and |
||
| 155 | +213 |
- stat_mean_pval <- function(x,+ #' `aov` (result of [car::Anova()]). |
||
| 156 | +214 |
- na.rm = TRUE, # nolint+ #' |
||
| 157 | +215 |
- n_min = 2,+ #' @noRd |
||
| 158 | +216 |
- test_mean = 0) {
- |
- ||
| 159 | -363x | -
- if (na.rm) {
- |
- ||
| 160 | -4x | -
- x <- stats::na.omit(x)+ fit_n_aov <- function(formula, |
||
| 161 | +217 |
- }+ data = data, |
||
| 162 | -363x | +|||
| 218 | +
- n <- length(x)+ conf_level = conf_level, |
|||
| 163 | +219 |
-
+ pval_method = c("wald", "likelihood"),
|
||
| 164 | -363x | +|||
| 220 | +
- x_mean <- mean(x)+ ...) {
|
|||
| 165 | -363x | +221 | +1x |
- x_sd <- stats::sd(x)+ pval_method <- match.arg(pval_method) |
| 166 | +222 | |||
| 167 | -363x | +223 | +1x |
- if (n < n_min) {
+ environment(formula) <- environment() |
| 168 | -53x | +224 | +1x |
- pv <- c(p_value = NA_real_)+ suppressWarnings({
|
| 169 | +225 |
- } else {
- |
- ||
| 170 | -310x | -
- x_se <- stats::sd(x) / sqrt(n)+ # We expect some warnings due to coxph which fails strict programming. |
||
| 171 | -310x | +226 | +1x |
- ttest <- (x_mean - test_mean) / x_se+ mod <- survival::coxph(formula, data = data, ...) |
| 172 | -310x | +227 | +1x |
- pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))+ msum <- summary(mod, conf.int = conf_level) |
| 173 | +228 |
- }+ }) |
||
| 174 | +229 | |||
| 175 | -363x | +230 | +1x |
- return(pv)+ aov <- try_car_anova( |
| 176 | -+ | |||
| 231 | +1x |
- }+ mod, |
||
| 177 | -+ | |||
| 232 | +1x |
-
+ test.statistic = switch(pval_method, |
||
| 178 | -+ | |||
| 233 | +1x |
- #' Proportion Difference and Confidence Interval+ "wald" = "Wald", |
||
| 179 | -+ | |||
| 234 | +1x |
- #'+ "likelihood" = "LR" |
||
| 180 | +235 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 181 | +236 |
- #'+ ) |
||
| 182 | +237 |
- #' Function for calculating the proportion (or risk) difference and confidence interval between arm+ |
||
| 183 | -+ | |||
| 238 | +1x |
- #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence+ warn_attr <- aov$warn_text |
||
| 184 | -+ | |||
| 239 | +! |
- #' in arm Y from cumulative incidence in arm X.+ if (!is.null(aov$warn_text)) message(warn_attr) |
||
| 185 | +240 |
- #'+ |
||
| 186 | -+ | |||
| 241 | +1x |
- #' @inheritParams argument_convention+ aov <- aov$aov |
||
| 187 | -+ | |||
| 242 | +1x |
- #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group).+ y <- list(mod = mod, msum = msum, aov = aov) |
||
| 188 | -+ | |||
| 243 | +1x |
- #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`.+ attr(y, "message") <- warn_attr |
||
| 189 | +244 |
- #' @param N_x (`numeric`)\cr total number of records in arm X.+ |
||
| 190 | -+ | |||
| 245 | +1x |
- #' @param N_y (`numeric`)\cr total number of records in arm Y.+ return(y) |
||
| 191 | +246 |
- #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in+ } |
||
| 192 | +247 |
- #' `x` and `y`. Must be of equal length to `x` and `y`.+ |
||
| 193 | +248 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ # argument_checks |
||
| 194 | +249 |
- #'+ check_formula <- function(formula) {
|
||
| 195 | -+ | |||
| 250 | +1x |
- #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and+ if (!(inherits(formula, "formula"))) {
|
||
| 196 | -+ | |||
| 251 | +1x |
- #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound.+ stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
|
||
| 197 | +252 |
- #'+ } |
||
| 198 | +253 |
- #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()]+ |
||
| 199 | -+ | |||
| 254 | +! |
- #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing+ invisible() |
||
| 200 | +255 |
- #' proportion (risk) difference to an `rtables` layout.+ } |
||
| 201 | +256 |
- #'+ |
||
| 202 | +257 |
- #' @examples+ check_covariate_formulas <- function(covariates) {
|
||
| 203 | -+ | |||
| 258 | +1x |
- #' stat_propdiff_ci(+ if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
|
||
| 204 | -+ | |||
| 259 | +1x |
- #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9+ stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
|
||
| 205 | +260 |
- #' )+ } |
||
| 206 | +261 |
- #'+ |
||
| 207 | -+ | |||
| 262 | +! |
- #' stat_propdiff_ci(+ invisible() |
||
| 208 | +263 |
- #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE+ } |
||
| 209 | +264 |
- #' )+ |
||
| 210 | +265 |
- #'+ name_covariate_names <- function(covariates) {
|
||
| 211 | -+ | |||
| 266 | +1x |
- #' @export+ miss_names <- names(covariates) == "" |
||
| 212 | -+ | |||
| 267 | +1x |
- stat_propdiff_ci <- function(x,+ no_names <- is.null(names(covariates)) |
||
| 213 | -+ | |||
| 268 | +! |
- y,+ if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name") |
||
| 214 | -+ | |||
| 269 | +! |
- N_x, # nolint+ if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
||
| 215 | -+ | |||
| 270 | +1x |
- N_y, # nolint+ return(covariates) |
||
| 216 | +271 |
- list_names = NULL,+ } |
||
| 217 | +272 |
- conf_level = 0.95,+ |
||
| 218 | +273 |
- pct = TRUE) {
+ check_increments <- function(increments, covariates) {
|
||
| 219 | -13x | +274 | +1x |
- checkmate::assert_list(x, types = "numeric")+ if (!is.null(increments)) {
|
| 220 | -13x | +275 | +1x |
- checkmate::assert_list(y, types = "numeric", len = length(x))+ covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
| 221 | -13x | +276 | +1x |
- checkmate::assert_character(list_names, len = length(x), null.ok = TRUE)+ lapply( |
| 222 | -13x | +277 | +1x |
- rd_list <- lapply(seq_along(x), function(i) {
+ X = names(increments), FUN = function(x) {
|
| 223 | -31x | +278 | +3x |
- p_x <- x[[i]] / N_x+ if (!x %in% covariates) {
|
| 224 | -31x | +279 | +1x |
- p_y <- y[[i]] / N_y+ warning( |
| 225 | -31x | +280 | +1x |
- rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) *+ paste( |
| 226 | -31x | +281 | +1x |
- sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y)+ "Check `increments`, the `increment` for ", x, |
| 227 | -31x | +282 | +1x |
- c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1)+ "doesn't match any names in investigated covariate(s)." |
| 228 | +283 |
- })+ ) |
||
| 229 | -13x | +|||
| 284 | +
- names(rd_list) <- list_names+ ) |
|||
| 230 | -13x | +|||
| 285 | +
- rd_list+ } |
|||
| 231 | +286 |
- }+ } |
| 1 | +287 |
- #' Survival Time Point Analysis+ ) |
||
| 2 | +288 |
- #'+ } |
||
| 3 | +289 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 290 | +1x |
- #'+ invisible() |
||
| 5 | +291 |
- #' Summarize patients' survival rate and difference of survival rates between groups at a time point.+ } |
||
| 6 | +292 |
- #'+ |
||
| 7 | +293 |
- #' @inheritParams argument_convention+ #' Multivariate Cox Model - Summarized Results |
||
| 8 | +294 |
- #' @inheritParams s_surv_time+ #' |
||
| 9 | +295 |
- #' @param time_point (`number`)\cr survival time point of interest.+ #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or |
||
| 10 | +296 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually |
||
| 11 | +297 |
- #' [control_surv_timepoint()]. Some possible parameter options are:+ #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the |
||
| 12 | +298 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ #' covariates included in the model. |
||
| 13 | +299 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the |
||
| 14 | +300 |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis, |
||
| 15 | +301 |
- #' * `time_point` (`number`)\cr survival time point of interest.+ #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**, |
||
| 16 | +302 |
- #' @param method (`string`)\cr either `surv` (survival estimations),+ #' `NEST's bookdown`) |
||
| 17 | +303 |
- #' `surv_diff` (difference in survival with the control) or `both`.+ #' |
||
| 18 | +304 |
- #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to+ #' @param formula (`formula`)\cr A formula corresponding to the investigated [survival::Surv()] survival model |
||
| 19 | +305 |
- #' avoid warnings from duplicate table names.+ #' including covariates. |
||
| 20 | +306 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_timepoint")`
+ #' @param data (`data.frame`)\cr A data frame which includes the variable in formula and covariates. |
||
| 21 | +307 |
- #' to see available statistics for this function.+ #' @param conf_level (`proportion`)\cr The confidence level for the hazard ratio interval estimations. Default is 0.95. |
||
| 22 | +308 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' @param pval_method (`character`)\cr The method used for the estimation of p-values, should be one of |
||
| 23 | +309 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' `"wald"` (default) or `"likelihood"`. |
||
| 24 | +310 |
- #' for that statistic's row label.+ #' @param ... Optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the |
||
| 25 | +311 |
- #'+ #' method for tie handling, one of `exact` (default), `efron`, `breslow`. |
||
| 26 | +312 |
- #' @name survival_timepoint+ #' |
||
| 27 | +313 |
- #' @order 1+ #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`. |
||
| 28 | +314 |
- NULL+ #' |
||
| 29 | +315 |
-
+ #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms |
||
| 30 | +316 |
- #' @describeIn survival_timepoint Statistics function which analyzes survival rate.+ #' but is out of scope as defined by the Global Data Standards Repository |
||
| 31 | +317 | ++ |
+ #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).+ |
+ |
| 318 |
#' |
|||
| 32 | +319 |
- #' @return+ #' @seealso [estimate_coef()]. |
||
| 33 | +320 |
- #' * `s_surv_timepoint()` returns the statistics:+ #' |
||
| 34 | +321 |
- #' * `pt_at_risk`: Patients remaining at risk.+ #' @examples |
||
| 35 | +322 |
- #' * `event_free_rate`: Event-free rate (%).+ #' library(dplyr) |
||
| 36 | +323 |
- #' * `rate_se`: Standard error of event free rate.+ #' |
||
| 37 | +324 |
- #' * `rate_ci`: Confidence interval for event free rate.+ #' adtte <- tern_ex_adtte |
||
| 38 | +325 |
- #'+ #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered |
||
| 39 | +326 |
- #' @keywords internal+ #' adtte_f <- filter( |
||
| 40 | +327 |
- s_surv_timepoint <- function(df,+ #' adtte_f, |
||
| 41 | +328 |
- .var,+ #' PARAMCD == "OS" & |
||
| 42 | +329 |
- time_point,+ #' SEX %in% c("F", "M") &
|
||
| 43 | +330 |
- is_event,+ #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
|
||
| 44 | +331 |
- control = control_surv_timepoint()) {
+ #' )+ |
+ ||
| 332 | ++ |
+ #' adtte_f$SEX <- droplevels(adtte_f$SEX)+ |
+ ||
| 333 | ++ |
+ #' adtte_f$RACE <- droplevels(adtte_f$RACE)+ |
+ ||
| 334 | ++ |
+ #'+ |
+ ||
| 335 | ++ |
+ #' @keywords internal+ |
+ ||
| 336 | ++ |
+ s_cox_multivariate <- function(formula, data,+ |
+ ||
| 337 | ++ |
+ conf_level = 0.95,+ |
+ ||
| 338 | ++ |
+ pval_method = c("wald", "likelihood"),
+ |
+ ||
| 339 | ++ |
+ ...) {
|
||
| 45 | -23x | +340 | +1x |
- checkmate::assert_string(.var)+ tf <- stats::terms(formula, specials = c("strata"))
|
| 46 | -23x | +341 | +1x |
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))] |
| 47 | -23x | +342 | +1x |
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ lapply( |
| 48 | -23x | +343 | +1x |
- checkmate::assert_number(time_point)+ X = covariates, |
| 49 | -23x | +344 | +1x |
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ FUN = function(x) {
+ |
+
| 345 | +3x | +
+ if (is.character(data[[x]])) {
+ |
+ ||
| 346 | +1x | +
+ data[[x]] <<- as.factor(data[[x]]) |
||
| 50 | +347 |
-
+ } |
||
| 51 | -23x | +348 | +3x |
- conf_type <- control$conf_type+ invisible()+ |
+
| 349 | ++ |
+ }+ |
+ ||
| 350 | ++ |
+ ) |
||
| 52 | -23x | +351 | +1x |
- conf_level <- control$conf_level+ pval_method <- match.arg(pval_method) |
| 53 | +352 | |||
| 54 | -23x | +|||
| 353 | +
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ # Results directly exported from environment(fit_n_aov) to environment(s_function_draft) |
|||
| 55 | -23x | +354 | +1x |
- srv_fit <- survival::survfit(+ y <- fit_n_aov( |
| 56 | -23x | +355 | +1x |
formula = formula, |
| 57 | -23x | +356 | +1x |
- data = df,+ data = data, |
| 58 | -23x | +357 | +1x |
- conf.int = conf_level,+ conf_level = conf_level, |
| 59 | -23x | +358 | +1x |
- conf.type = conf_type+ pval_method = pval_method, |
| 60 | +359 | ++ |
+ ...+ |
+ |
| 360 |
) |
|||
| 61 | -23x | +361 | +1x |
- s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE)+ mod <- y$mod |
| 62 | -23x | +362 | +1x |
- df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
+ aov <- y$aov |
| 63 | -23x | +363 | +1x |
- if (df_srv_fit[["n.risk"]] == 0) {
+ msum <- y$msum |
| 64 | +364 | 1x |
- pt_at_risk <- event_free_rate <- rate_se <- NA_real_+ list2env(as.list(y), environment())+ |
+ |
| 365 | ++ | + | ||
| 65 | +366 | 1x |
- rate_ci <- c(NA_real_, NA_real_)+ all_term_labs <- attr(mod$terms, "term.labels")+ |
+ |
| 367 | +1x | +
+ term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]+ |
+ ||
| 368 | +1x | +
+ names(term_labs) <- term_labs |
||
| 66 | +369 |
- } else {
+
|
||
| 67 | -22x | +370 | +1x |
- pt_at_risk <- df_srv_fit$n.risk+ coef_inter <- NULL |
| 68 | -22x | +371 | +1x |
- event_free_rate <- df_srv_fit$surv+ if (any(attr(mod$terms, "order") > 1)) {
|
| 69 | -22x | +372 | +1x |
- rate_se <- df_srv_fit$std.err+ for_inter <- all_term_labs[attr(mod$terms, "order") > 1] |
| 70 | -22x | +373 | +1x |
- rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)+ names(for_inter) <- for_inter+ |
+
| 374 | +1x | +
+ mmat <- stats::model.matrix(mod)[1, ]+ |
+ ||
| 375 | +1x | +
+ mmat[!mmat == 0] <- 0+ |
+ ||
| 376 | +1x | +
+ mcoef <- stats::coef(mod)+ |
+ ||
| 377 | +1x | +
+ mvcov <- stats::vcov(mod) |
||
| 71 | +378 |
- }+ |
||
| 72 | -23x | +379 | +1x |
- list(+ estimate_coef_local <- function(variable, given) {
|
| 73 | -23x | +380 | +6x |
- pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),+ estimate_coef( |
| 74 | -23x | +381 | +6x |
- event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),+ variable, given, |
| 75 | -23x | +382 | +6x |
- rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),+ coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level, |
| 76 | -23x | +383 | +6x |
- rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level))+ lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]]) |
| 77 | +384 |
- )+ ) |
||
| 78 | +385 |
- }+ } |
||
| 79 | +386 | |||
| 80 | -+ | |||
| 387 | +1x |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ coef_inter <- lapply( |
||
| 81 | -+ | |||
| 388 | +1x |
- #' when `method = "surv"`.+ for_inter, function(x) {
|
||
| 82 | -+ | |||
| 389 | +3x |
- #'+ y <- attr(mod$terms, "factor")[, x] |
||
| 83 | -+ | |||
| 390 | +3x |
- #' @return+ y <- names(y[y > 0]) |
||
| 84 | -+ | |||
| 391 | +3x |
- #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()].+ Map(estimate_coef_local, variable = y, given = rev(y)) |
||
| 85 | +392 |
- #'+ } |
||
| 86 | +393 |
- #' @keywords internal+ ) |
||
| 87 | +394 |
- a_surv_timepoint <- make_afun(+ } |
||
| 88 | +395 |
- s_surv_timepoint,+ |
||
| 89 | -+ | |||
| 396 | +1x |
- .indent_mods = c(+ list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter) |
||
| 90 | +397 |
- pt_at_risk = 0L,+ } |
| 91 | +1 |
- event_free_rate = 0L,+ #' Confidence Interval for Mean |
||
| 92 | +2 |
- rate_se = 1L,+ #' |
||
| 93 | +3 |
- rate_ci = 1L+ #' @description `r lifecycle::badge("stable")`
|
||
| 94 | +4 |
- ),+ #' |
||
| 95 | +5 |
- .formats = c(+ #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the |
||
| 96 | +6 |
- pt_at_risk = "xx",+ #' geometric mean. It can be used as a `ggplot` helper function for plotting. |
||
| 97 | +7 |
- event_free_rate = "xx.xx",+ #' |
||
| 98 | +8 |
- rate_se = "xx.xx",+ #' @inheritParams argument_convention |
||
| 99 | +9 |
- rate_ci = "(xx.xx, xx.xx)"+ #' @param n_min (`number`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean. |
||
| 100 | +10 |
- )+ #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`. |
||
| 101 | +11 |
- )+ #' @param geom_mean (`logical`)\cr `TRUE` when the geometric mean should be calculated. |
||
| 102 | +12 |
-
+ #' |
||
| 103 | +13 |
- #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates.+ #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`. |
||
| 104 | +14 |
#' |
||
| 105 | +15 |
- #' @return+ #' @examples |
||
| 106 | +16 |
- #' * `s_surv_timepoint_diff()` returns the statistics:+ #' stat_mean_ci(sample(10), gg_helper = FALSE) |
||
| 107 | +17 |
- #' * `rate_diff`: Event-free rate difference between two groups.+ #' |
||
| 108 | +18 |
- #' * `rate_diff_ci`: Confidence interval for the difference.+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 109 | +19 |
- #' * `ztest_pval`: p-value to test the difference is 0.+ #' ggplot2::geom_point() |
||
| 110 | +20 |
#' |
||
| 111 | +21 |
- #' @keywords internal+ #' p + ggplot2::stat_summary( |
||
| 112 | +22 |
- s_surv_timepoint_diff <- function(df,+ #' fun.data = stat_mean_ci, |
||
| 113 | +23 |
- .var,+ #' geom = "errorbar" |
||
| 114 | +24 |
- .ref_group,+ #' ) |
||
| 115 | +25 |
- .in_ref_col,+ #' |
||
| 116 | +26 |
- time_point,+ #' p + ggplot2::stat_summary( |
||
| 117 | +27 |
- control = control_surv_timepoint(),+ #' fun.data = stat_mean_ci, |
||
| 118 | +28 |
- ...) {
- |
- ||
| 119 | -2x | -
- if (.in_ref_col) {
+ #' fun.args = list(conf_level = 0.5), |
||
| 120 | -! | +|||
| 29 | +
- return(+ #' geom = "errorbar" |
|||
| 121 | -! | +|||
| 30 | +
- list(+ #' ) |
|||
| 122 | -! | +|||
| 31 | +
- rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
+ #' |
|||
| 123 | -! | +|||
| 32 | +
- rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ #' p + ggplot2::stat_summary( |
|||
| 124 | -! | +|||
| 33 | +
- ztest_pval = formatters::with_label("", "p-value (Z-test)")
+ #' fun.data = stat_mean_ci, |
|||
| 125 | +34 |
- )+ #' fun.args = list(conf_level = 0.5, geom_mean = TRUE), |
||
| 126 | +35 |
- )+ #' geom = "errorbar" |
||
| 127 | +36 |
- }+ #' ) |
||
| 128 | -2x | +|||
| 37 | +
- data <- rbind(.ref_group, df)+ #' |
|||
| 129 | -2x | +|||
| 38 | +
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ #' @export |
|||
| 130 | -2x | +|||
| 39 | +
- res_per_group <- lapply(split(data, group), function(x) {
+ stat_mean_ci <- function(x, |
|||
| 131 | -4x | +|||
| 40 | +
- s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...)+ conf_level = 0.95, |
|||
| 132 | +41 |
- })+ na.rm = TRUE, # nolint |
||
| 133 | +42 |
-
+ n_min = 2, |
||
| 134 | -2x | +|||
| 43 | +
- res_x <- res_per_group[[2]]+ gg_helper = TRUE, |
|||
| 135 | -2x | +|||
| 44 | +
- res_ref <- res_per_group[[1]]+ geom_mean = FALSE) {
|
|||
| 136 | -2x | +45 | +720x |
- rate_diff <- res_x$event_free_rate - res_ref$event_free_rate+ if (na.rm) {
|
| 137 | +46 | 2x |
- se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2)+ x <- stats::na.omit(x) |
|
| 138 | +47 |
-
+ } |
||
| 139 | -2x | +48 | +720x |
- qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2)+ n <- length(x) |
| 140 | -2x | +|||
| 49 | +
- rate_diff_ci <- rate_diff + qs * se_diff+ |
|||
| 141 | -2x | +50 | +720x |
- ztest_pval <- if (is.na(rate_diff)) {
+ if (!geom_mean) {
|
| 142 | -2x | +51 | +361x |
- NA+ m <- mean(x) |
| 143 | +52 |
} else {
|
||
| 144 | -2x | +53 | +359x |
- 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff))+ negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0) |
| 145 | -+ | |||
| 54 | +359x |
- }+ if (negative_values_exist) {
|
||
| 146 | -2x | +55 | +22x |
- list(+ m <- NA_real_ |
| 147 | -2x | +|||
| 56 | +
- rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),+ } else {
|
|||
| 148 | -2x | +57 | +337x |
- rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),+ x <- log(x) |
| 149 | -2x | +58 | +337x |
- ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)")+ m <- mean(x) |
| 150 | +59 |
- )+ } |
||
| 151 | +60 |
- }+ } |
||
| 152 | +61 | |||
| 153 | -+ | |||
| 62 | +720x |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ if (n < n_min || is.na(m)) {
|
||
| 154 | -+ | |||
| 63 | +122x |
- #' when `method = "surv_diff"`.+ ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_) |
||
| 155 | +64 |
- #'+ } else {
|
||
| 156 | -+ | |||
| 65 | +598x |
- #' @return+ hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n) |
||
| 157 | -+ | |||
| 66 | +598x |
- #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci) |
||
| 158 | -+ | |||
| 67 | +598x |
- #'+ if (geom_mean) {
|
||
| 159 | -+ | |||
| 68 | +291x |
- #' @keywords internal+ ci <- exp(ci) |
||
| 160 | +69 |
- a_surv_timepoint_diff <- make_afun(+ } |
||
| 161 | +70 |
- s_surv_timepoint_diff,+ } |
||
| 162 | +71 |
- .formats = c(+ |
||
| 163 | -+ | |||
| 72 | +720x |
- rate_diff = "xx.xx",+ if (gg_helper) {
|
||
| 164 | -+ | |||
| 73 | +! |
- rate_diff_ci = "(xx.xx, xx.xx)",+ m <- ifelse(is.na(m), NA_real_, m) |
||
| 165 | -+ | |||
| 74 | +! |
- ztest_pval = "x.xxxx | (<0.0001)"+ ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]]) |
||
| 166 | +75 |
- )+ } |
||
| 167 | +76 |
- )+ |
||
| 168 | -+ | |||
| 77 | +720x |
-
+ return(ci) |
||
| 169 | +78 |
- #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments+ } |
||
| 170 | +79 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
||
| 171 | +80 |
- #'+ #' Confidence Interval for Median |
||
| 172 | +81 |
- #' @return+ #' |
||
| 173 | +82 |
- #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions,+ #' @description `r lifecycle::badge("stable")`
|
||
| 174 | +83 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 175 | +84 |
- #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on+ #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper |
||
| 176 | +85 |
- #' the value of `method`.+ #' function for plotting. |
||
| 177 | +86 |
#' |
||
| 178 | +87 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 179 | +88 |
- #' library(dplyr)+ #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`. |
||
| 180 | +89 |
#' |
||
| 181 | +90 |
- #' adtte_f <- tern_ex_adtte %>%+ #' @details The function was adapted from `DescTools/versions/0.99.35/source` |
||
| 182 | +91 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 183 | +92 |
- #' mutate(+ #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`. |
||
| 184 | +93 |
- #' AVAL = day2month(AVAL),+ #' |
||
| 185 | +94 |
- #' is_event = CNSR == 0+ #' @examples |
||
| 186 | +95 |
- #' )+ #' stat_median_ci(sample(10), gg_helper = FALSE) |
||
| 187 | +96 |
#' |
||
| 188 | +97 |
- #' # Survival at given time points.+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 189 | +98 |
- #' basic_table() %>%+ #' ggplot2::geom_point() |
||
| 190 | +99 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' p + ggplot2::stat_summary( |
||
| 191 | +100 |
- #' add_colcounts() %>%+ #' fun.data = stat_median_ci, |
||
| 192 | +101 |
- #' surv_timepoint(+ #' geom = "errorbar" |
||
| 193 | +102 |
- #' vars = "AVAL",+ #' ) |
||
| 194 | +103 |
- #' var_labels = "Months",+ #' |
||
| 195 | +104 |
- #' is_event = "is_event",+ #' @export |
||
| 196 | +105 |
- #' time_point = 7+ stat_median_ci <- function(x, |
||
| 197 | +106 |
- #' ) %>%+ conf_level = 0.95, |
||
| 198 | +107 |
- #' build_table(df = adtte_f)+ na.rm = TRUE, # nolint |
||
| 199 | +108 |
- #'+ gg_helper = TRUE) {
|
||
| 200 | -+ | |||
| 109 | +362x |
- #' # Difference in survival at given time points.+ x <- unname(x) |
||
| 201 | -+ | |||
| 110 | +362x |
- #' basic_table() %>%+ if (na.rm) {
|
||
| 202 | -+ | |||
| 111 | +3x |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ x <- x[!is.na(x)] |
||
| 203 | +112 |
- #' add_colcounts() %>%+ } |
||
| 204 | -+ | |||
| 113 | +362x |
- #' surv_timepoint(+ n <- length(x) |
||
| 205 | -+ | |||
| 114 | +362x |
- #' vars = "AVAL",+ med <- stats::median(x) |
||
| 206 | +115 |
- #' var_labels = "Months",+ |
||
| 207 | -+ | |||
| 116 | +362x |
- #' is_event = "is_event",+ k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE) |
||
| 208 | +117 |
- #' time_point = 9,+ |
||
| 209 | +118 |
- #' method = "surv_diff",+ # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range |
||
| 210 | -+ | |||
| 119 | +362x |
- #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
+ if (k == 0 || is.na(med)) {
|
||
| 211 | -+ | |||
| 120 | +98x |
- #' ) %>%+ ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_) |
||
| 212 | -+ | |||
| 121 | +98x |
- #' build_table(df = adtte_f)+ empir_conf_level <- NA_real_ |
||
| 213 | +122 |
- #'+ } else {
|
||
| 214 | -+ | |||
| 123 | +264x |
- #' # Survival and difference in survival at given time points.+ x_sort <- sort(x) |
||
| 215 | -+ | |||
| 124 | +264x |
- #' basic_table() %>%+ ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1]) |
||
| 216 | -+ | |||
| 125 | +264x |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5) |
||
| 217 | +126 |
- #' add_colcounts() %>%+ } |
||
| 218 | +127 |
- #' surv_timepoint(+ |
||
| 219 | -+ | |||
| 128 | +362x |
- #' vars = "AVAL",+ if (gg_helper) {
+ |
+ ||
| 129 | +! | +
+ ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]]) |
||
| 220 | +130 |
- #' var_labels = "Months",+ } |
||
| 221 | +131 |
- #' is_event = "is_event",+ + |
+ ||
| 132 | +362x | +
+ attr(ci, "conf_level") <- empir_conf_level |
||
| 222 | +133 |
- #' time_point = 9,+ + |
+ ||
| 134 | +362x | +
+ return(ci) |
||
| 223 | +135 |
- #' method = "both"+ } |
||
| 224 | +136 |
- #' ) %>%+ |
||
| 225 | +137 |
- #' build_table(df = adtte_f)+ #' p-Value of the Mean |
||
| 226 | +138 |
#' |
||
| 227 | +139 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 228 | +140 |
- #' @order 2+ #' |
||
| 229 | +141 |
- surv_timepoint <- function(lyt,+ #' Convenient function for calculating the two-sided p-value of the mean. |
||
| 230 | +142 |
- vars,+ #' |
||
| 231 | +143 |
- time_point,+ #' @inheritParams argument_convention |
||
| 232 | +144 |
- is_event,+ #' @param n_min (`numeric`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean. |
||
| 233 | +145 |
- control = control_surv_timepoint(),+ #' @param test_mean (`numeric`)\cr mean value to test under the null hypothesis. |
||
| 234 | +146 |
- method = c("surv", "surv_diff", "both"),
+ #' |
||
| 235 | +147 |
- na_str = default_na_str(),+ #' @return A p-value. |
||
| 236 | +148 |
- nested = TRUE,+ #' |
||
| 237 | +149 |
- ...,+ #' @examples |
||
| 238 | +150 |
- table_names_suffix = "",+ #' stat_mean_pval(sample(10)) |
||
| 239 | +151 |
- var_labels = "Time",+ #' |
||
| 240 | +152 |
- show_labels = "visible",+ #' stat_mean_pval(rnorm(10), test_mean = 0.5) |
||
| 241 | +153 |
- .stats = c(+ #' |
||
| 242 | +154 |
- "pt_at_risk", "event_free_rate", "rate_ci",+ #' @export |
||
| 243 | +155 |
- "rate_diff", "rate_diff_ci", "ztest_pval"+ stat_mean_pval <- function(x, |
||
| 244 | +156 |
- ),+ na.rm = TRUE, # nolint |
||
| 245 | +157 |
- .formats = NULL,+ n_min = 2, |
||
| 246 | +158 |
- .labels = NULL,+ test_mean = 0) {
|
||
| 247 | -+ | |||
| 159 | +363x |
- .indent_mods = if (method == "both") {
+ if (na.rm) {
|
||
| 248 | -2x | +160 | +4x |
- c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L)+ x <- stats::na.omit(x) |
| 249 | +161 |
- } else {
+ } |
||
| 250 | -4x | +162 | +363x |
- c(rate_diff_ci = 1L, ztest_pval = 1L)+ n <- length(x) |
| 251 | +163 |
- }) {
+
|
||
| 252 | -6x | +164 | +363x |
- method <- match.arg(method)+ x_mean <- mean(x) |
| 253 | -6x | +165 | +363x |
- checkmate::assert_string(table_names_suffix)+ x_sd <- stats::sd(x) |
| 254 | +166 | |||
| 255 | -6x | +167 | +363x |
- extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...)+ if (n < n_min) {
+ |
+
| 168 | +53x | +
+ pv <- c(p_value = NA_real_) |
||
| 256 | +169 |
-
+ } else {
|
||
| 257 | -6x | +170 | +310x |
- f <- list(+ x_se <- stats::sd(x) / sqrt(n) |
| 258 | -6x | +171 | +310x |
- surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ ttest <- (x_mean - test_mean) / x_se |
| 259 | -6x | +172 | +310x |
- surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1)) |
| 260 | +173 |
- )+ } |
||
| 261 | -6x | +|||
| 174 | +
- .stats <- h_split_param(.stats, .stats, f = f)+ |
|||
| 262 | -6x | +175 | +363x |
- .formats <- h_split_param(.formats, names(.formats), f = f)+ return(pv) |
| 263 | -6x | +|||
| 176 | +
- .labels <- h_split_param(.labels, names(.labels), f = f)+ } |
|||
| 264 | -6x | +|||
| 177 | +
- .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f)+ |
|||
| 265 | +178 |
-
+ #' Proportion Difference and Confidence Interval |
||
| 266 | -6x | +|||
| 179 | +
- afun_surv <- make_afun(+ #' |
|||
| 267 | -6x | +|||
| 180 | +
- a_surv_timepoint,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 268 | -6x | +|||
| 181 | +
- .stats = .stats$surv,+ #' |
|||
| 269 | -6x | +|||
| 182 | +
- .formats = .formats$surv,+ #' Function for calculating the proportion (or risk) difference and confidence interval between arm |
|||
| 270 | -6x | +|||
| 183 | +
- .labels = .labels$surv,+ #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence |
|||
| 271 | -6x | +|||
| 184 | +
- .indent_mods = .indent_mods$surv+ #' in arm Y from cumulative incidence in arm X. |
|||
| 272 | +185 |
- )+ #' |
||
| 273 | +186 |
-
+ #' @inheritParams argument_convention |
||
| 274 | -6x | +|||
| 187 | +
- afun_surv_diff <- make_afun(+ #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group). |
|||
| 275 | -6x | +|||
| 188 | +
- a_surv_timepoint_diff,+ #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`. |
|||
| 276 | -6x | +|||
| 189 | +
- .stats = .stats$surv_diff,+ #' @param N_x (`numeric`)\cr total number of records in arm X. |
|||
| 277 | -6x | +|||
| 190 | +
- .formats = .formats$surv_diff,+ #' @param N_y (`numeric`)\cr total number of records in arm Y. |
|||
| 278 | -6x | +|||
| 191 | +
- .labels = .labels$surv_diff,+ #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in |
|||
| 279 | -6x | +|||
| 192 | +
- .indent_mods = .indent_mods$surv_diff+ #' `x` and `y`. Must be of equal length to `x` and `y`. |
|||
| 280 | +193 |
- )+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
||
| 281 | +194 |
-
+ #' |
||
| 282 | -6x | +|||
| 195 | +
- time_point <- extra_args$time_point+ #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and |
|||
| 283 | +196 |
-
+ #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound. |
||
| 284 | -6x | +|||
| 197 | +
- for (i in seq_along(time_point)) {
+ #' |
|||
| 285 | -6x | +|||
| 198 | +
- extra_args[["time_point"]] <- time_point[i]+ #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] |
|||
| 286 | +199 |
-
+ #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing |
||
| 287 | -6x | +|||
| 200 | +
- if (method %in% c("surv", "both")) {
+ #' proportion (risk) difference to an `rtables` layout. |
|||
| 288 | -4x | +|||
| 201 | +
- lyt <- analyze(+ #' |
|||
| 289 | -4x | +|||
| 202 | +
- lyt,+ #' @examples |
|||
| 290 | -4x | +|||
| 203 | +
- vars,+ #' stat_propdiff_ci( |
|||
| 291 | -4x | +|||
| 204 | +
- var_labels = paste(time_point[i], var_labels),+ #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9 |
|||
| 292 | -4x | +|||
| 205 | +
- table_names = paste0("surv_", time_point[i], table_names_suffix),
+ #' ) |
|||
| 293 | -4x | +|||
| 206 | +
- show_labels = show_labels,+ #' |
|||
| 294 | -4x | +|||
| 207 | +
- afun = afun_surv,+ #' stat_propdiff_ci( |
|||
| 295 | -4x | +|||
| 208 | +
- na_str = na_str,+ #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE |
|||
| 296 | -4x | +|||
| 209 | +
- nested = nested,+ #' ) |
|||
| 297 | -4x | +|||
| 210 | +
- extra_args = extra_args+ #' |
|||
| 298 | +211 |
- )+ #' @export |
||
| 299 | +212 |
- }+ stat_propdiff_ci <- function(x, |
||
| 300 | +213 |
-
+ y, |
||
| 301 | -6x | +|||
| 214 | +
- if (method %in% c("surv_diff", "both")) {
+ N_x, # nolint |
|||
| 302 | -4x | +|||
| 215 | +
- lyt <- analyze(+ N_y, # nolint |
|||
| 303 | -4x | +|||
| 216 | +
- lyt,+ list_names = NULL,+ |
+ |||
| 217 | ++ |
+ conf_level = 0.95,+ |
+ ||
| 218 | ++ |
+ pct = TRUE) {
|
||
| 304 | -4x | +219 | +13x |
- vars,+ checkmate::assert_list(x, types = "numeric") |
| 305 | -4x | +220 | +13x |
- var_labels = paste(time_point[i], var_labels),+ checkmate::assert_list(y, types = "numeric", len = length(x)) |
| 306 | -4x | +221 | +13x |
- table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
+ checkmate::assert_character(list_names, len = length(x), null.ok = TRUE) |
| 307 | -4x | +222 | +13x |
- show_labels = ifelse(method == "both", "hidden", show_labels),+ rd_list <- lapply(seq_along(x), function(i) {
|
| 308 | -4x | +223 | +31x |
- afun = afun_surv_diff,+ p_x <- x[[i]] / N_x |
| 309 | -4x | +224 | +31x |
- na_str = na_str,+ p_y <- y[[i]] / N_y |
| 310 | -4x | +225 | +31x |
- nested = nested,+ rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) * |
| 311 | -4x | +226 | +31x |
- extra_args = extra_args+ sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y) |
| 312 | -+ | |||
| 227 | +31x |
- )+ c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1) |
||
| 313 | +228 |
- }+ }) |
||
| 314 | -+ | |||
| 229 | +13x |
- }+ names(rd_list) <- list_names |
||
| 315 | -6x | +230 | +13x |
- lyt+ rd_list |
| 316 | +231 |
}@@ -10088,14 +10158,14 @@ tern coverage - 90.46% |
| 1 |
- #' Create a forest plot from an `rtable`+ #' Re-implemented [range()] Default S3 method for numerical objects |
||
| 3 |
- #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2+ #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data |
||
| 4 |
- #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The+ #' without any warnings. |
||
| 5 |
- #' table and forest plot are printed side-by-side.+ #' |
||
| 6 |
- #'+ #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed. |
||
| 7 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param na.rm (`logical`)\cr indicating if `NA` should be omitted. |
||
| 8 |
- #'+ #' @param finite (`logical`)\cr indicating if non-finite elements should be removed. |
||
| 9 |
- #' @inheritParams rtable2gg+ #' |
||
| 10 |
- #' @inheritParams argument_convention+ #' @return A 2-element vector of class `numeric`. |
||
| 11 |
- #' @param tbl (`rtable`)\cr table with at least one column with a single value and one column with 2 values.+ #' |
||
| 12 |
- #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from+ #' @keywords internal |
||
| 13 |
- #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded+ range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
|
||
| 14 |
- #' from forest plot.+ |
||
| 15 | -+ | 953x |
- #' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries to get this from+ checkmate::assert_numeric(x) |
| 16 |
- #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded+ |
||
| 17 | -+ | 953x |
- #' from forest plot.+ if (finite) {
|
| 18 | -+ | 24x |
- #' @param vline (`numeric`)\cr x coordinate for vertical line, if `NULL` then the line is omitted.+ x <- x[is.finite(x)] # removes NAs too |
| 19 | -+ | 929x |
- #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively.+ } else if (na.rm) {
|
| 20 | -+ | 558x |
- #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute+ x <- x[!is.na(x)] |
| 21 |
- #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to+ } |
||
| 22 |
- #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not.+ |
||
| 23 | -+ | 953x |
- #' @param xlim (`numeric`)\cr limits for x axis.+ if (length(x) == 0) {
|
| 24 | -+ | 52x |
- #' @param logx (`flag`)\cr show the x-values on logarithm scale.+ rval <- c(NA, NA) |
| 25 | -+ | 52x |
- #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values.+ mode(rval) <- typeof(x) |
| 26 |
- #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
+ } else {
|
||
| 27 | -+ | 901x |
- #' @param width_columns (`vector` of `numeric`)\cr a vector of column widths. Each element's position in+ rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE)) |
| 28 |
- #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated+ } |
||
| 29 |
- #' according to maximum number of characters per column.+ |
||
| 30 | -+ | 953x |
- #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
+ return(rval) |
| 31 |
- #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative+ } |
||
| 32 |
- #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored.+ |
||
| 33 |
- #' @param font_size (`numeric`)\cr font size.+ #' Utility function to create label for confidence interval |
||
| 34 |
- #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used+ #' |
||
| 35 |
- #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional+ #' @description `r lifecycle::badge("stable")`
|
||
| 36 |
- #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups.+ #' |
||
| 37 |
- #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified.+ #' @inheritParams argument_convention |
||
| 38 |
- #' @param col (`character`)\cr color(s).+ #' |
||
| 39 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ #' @return A `string`. |
||
| 40 |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list+ #' |
||
| 41 |
- #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are+ #' @export |
||
| 42 |
- #' printed side-by-side via [cowplot::plot_grid()].+ f_conf_level <- function(conf_level) {
|
||
| 43 | -+ | 1521x |
- #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ assert_proportion_value(conf_level) |
| 44 | -+ | 1519x |
- #' is no longer used.+ paste0(conf_level * 100, "% CI") |
| 45 |
- #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ } |
||
| 46 |
- #' is no longer used.+ |
||
| 47 |
- #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ #' Utility function to create label for p-value |
||
| 48 |
- #' is no longer used.+ #' |
||
| 49 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 50 |
- #' @return `ggplot` forest plot and table.+ #' |
||
| 51 |
- #'+ #' @param test_mean (`number`)\cr mean value to test under the null hypothesis. |
||
| 52 |
- #' @examples+ #' |
||
| 53 |
- #' library(dplyr)+ #' @return A `string`. |
||
| 54 |
- #' library(forcats)+ #' |
||
| 55 |
- #' library(nestcolor)+ #' @export |
||
| 56 |
- #'+ f_pval <- function(test_mean) {
|
||
| 57 | -+ | 363x |
- #' adrs <- tern_ex_adrs+ checkmate::assert_numeric(test_mean, len = 1) |
| 58 | -+ | 361x |
- #' n_records <- 20+ paste0("p-value (H0: mean = ", test_mean, ")")
|
| 59 |
- #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE)+ } |
||
| 60 |
- #' adrs <- adrs %>%+ |
||
| 61 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' Utility function to return a named list of covariate names. |
||
| 62 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ #' |
||
| 63 |
- #' slice(seq_len(n_records)) %>%+ #' @param covariates (`character`)\cr a vector that can contain single variable names (such as |
||
| 64 |
- #' droplevels() %>%+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
||
| 65 |
- #' mutate(+ #' |
||
| 66 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ #' @return A named `list` of `character` vector. |
||
| 67 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ #' |
||
| 68 |
- #' rsp = AVALC == "CR"+ #' @keywords internal |
||
| 69 |
- #' )+ get_covariates <- function(covariates) {
|
||
| 70 | -+ | 14x |
- #' formatters::var_labels(adrs) <- c(adrs_labels, "Response")+ checkmate::assert_character(covariates) |
| 71 | -+ | 12x |
- #' df <- extract_rsp_subgroups(+ cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*")))) |
| 72 | -+ | 12x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
+ stats::setNames(as.list(cov_vars), cov_vars) |
| 73 |
- #' data = adrs+ } |
||
| 74 |
- #' )+ |
||
| 75 |
- #' # Full commonly used response table.+ #' Replicate Entries of a Vector if Required |
||
| 77 |
- #' tbl <- basic_table() %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 78 |
- #' tabulate_rsp_subgroups(df)+ #' |
||
| 79 |
- #' g_forest(tbl)+ #' Replicate entries of a vector if required. |
||
| 81 |
- #' # Odds ratio only table.+ #' @inheritParams argument_convention |
||
| 82 |
- #'+ #' @param n (`count`)\cr how many entries we need. |
||
| 83 |
- #' tbl_or <- basic_table() %>%+ #' |
||
| 84 |
- #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
+ #' @return `x` if it has the required length already or is `NULL`, |
||
| 85 |
- #' g_forest(+ #' otherwise if it is scalar the replicated version of it with `n` entries. |
||
| 86 |
- #' tbl_or,+ #' |
||
| 87 |
- #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
+ #' @note This function will fail if `x` is not of length `n` and/or is not a scalar. |
||
| 88 |
- #' )+ #' |
||
| 89 |
- #'+ #' @export |
||
| 90 |
- #' # Survival forest plot example.+ to_n <- function(x, n) {
|
||
| 91 | -+ | 1x |
- #' adtte <- tern_ex_adtte+ if (is.null(x)) {
|
| 92 | -+ | ! |
- #' # Save variable labels before data processing steps.+ NULL |
| 93 | -+ | 1x |
- #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE)+ } else if (length(x) == 1) {
|
| 94 | -+ | ! |
- #' adtte_f <- adtte %>%+ rep(x, n) |
| 95 | -+ | 1x |
- #' filter(+ } else if (length(x) == n) {
|
| 96 | -+ | 1x |
- #' PARAMCD == "OS",+ x |
| 97 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ } else {
|
||
| 98 | -+ | ! |
- #' SEX %in% c("M", "F")
+ stop("dimension mismatch")
|
| 99 |
- #' ) %>%+ } |
||
| 100 |
- #' mutate(+ } |
||
| 101 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ |
||
| 102 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ #' Check Element Dimension |
||
| 103 |
- #' SEX = droplevels(SEX),+ #' |
||
| 104 |
- #' AVALU = as.character(AVALU),+ #' Checks if the elements in `...` have the same dimension. |
||
| 105 |
- #' is_event = CNSR == 0+ #' |
||
| 106 |
- #' )+ #' @param ... (`data.frame`s or `vector`s)\cr any data frames/vectors. |
||
| 107 |
- #' labels <- list(+ #' @param omit_null (`logical`)\cr whether `NULL` elements in `...` should be omitted from the check. |
||
| 108 |
- #' "ARM" = adtte_labels["ARM"],+ #' |
||
| 109 |
- #' "SEX" = adtte_labels["SEX"],+ #' @return A `logical` value. |
||
| 110 |
- #' "AVALU" = adtte_labels["AVALU"],+ #' |
||
| 111 |
- #' "is_event" = "Event Flag"+ #' @keywords internal |
||
| 112 |
- #' )+ check_same_n <- function(..., omit_null = TRUE) {
|
||
| 113 | -+ | 2x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels)+ dots <- list(...) |
| 114 |
- #' df <- extract_survival_subgroups(+ |
||
| 115 | -+ | 2x |
- #' variables = list(+ n_list <- Map( |
| 116 | -+ | 2x |
- #' tte = "AVAL",+ function(x, name) {
|
| 117 | -+ | 5x |
- #' is_event = "is_event",+ if (is.null(x)) {
|
| 118 | -+ | ! |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ if (omit_null) {
|
| 119 | -+ | 2x |
- #' ),+ NA_integer_ |
| 120 |
- #' data = adtte_f+ } else {
|
||
| 121 | -+ | ! |
- #' )+ stop("arg", name, "is not supposed to be NULL")
|
| 122 |
- #' table_hr <- basic_table() %>%+ } |
||
| 123 | -+ | 5x |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ } else if (is.data.frame(x)) {
|
| 124 | -+ | ! |
- #' g_forest(table_hr)+ nrow(x) |
| 125 | -+ | 5x |
- #'+ } else if (is.atomic(x)) {
|
| 126 | -+ | 5x |
- #' # Works with any `rtable`.+ length(x) |
| 127 |
- #' tbl <- rtable(+ } else {
|
||
| 128 | -+ | ! |
- #' header = c("E", "CI", "N"),
+ stop("data structure for ", name, "is currently not supported")
|
| 129 |
- #' rrow("", 1, c(.8, 1.2), 200),
+ } |
||
| 130 |
- #' rrow("", 1.2, c(1.1, 1.4), 50)
+ }, |
||
| 131 | -+ | 2x |
- #' )+ dots, names(dots) |
| 132 |
- #' g_forest(+ ) |
||
| 133 |
- #' tbl = tbl,+ |
||
| 134 | -+ | 2x |
- #' col_x = 1,+ n <- stats::na.omit(unlist(n_list)) |
| 135 |
- #' col_ci = 2,+ |
||
| 136 | -+ | 2x |
- #' xlim = c(0.5, 2),+ if (length(unique(n)) > 1) {
|
| 137 | -+ | ! |
- #' x_at = c(0.5, 1, 2),+ sel <- which(n != n[1]) |
| 138 | -+ | ! |
- #' col_symbol_size = 3+ stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
|
| 139 |
- #' )+ } |
||
| 140 |
- #'+ |
||
| 141 | -+ | 2x |
- #' tbl <- rtable(+ TRUE |
| 142 |
- #' header = rheader(+ } |
||
| 143 |
- #' rrow("", rcell("A", colspan = 2)),
+
|
||
| 144 |
- #' rrow("", "c1", "c2")
+ #' Make Names Without Dots |
||
| 145 |
- #' ),+ #' |
||
| 146 |
- #' rrow("row 1", 1, c(.8, 1.2)),
+ #' @param nams (`character`)\cr vector of original names. |
||
| 147 |
- #' rrow("row 2", 1.2, c(1.1, 1.4))
+ #' |
||
| 148 |
- #' )+ #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()]. |
||
| 149 |
- #' g_forest(+ #' |
||
| 150 |
- #' tbl = tbl,+ #' @keywords internal |
||
| 151 |
- #' col_x = 1,+ make_names <- function(nams) {
|
||
| 152 | -+ | 6x |
- #' col_ci = 2,+ orig <- make.names(nams) |
| 153 | -+ | 6x |
- #' xlim = c(0.5, 2),+ gsub(".", "", x = orig, fixed = TRUE)
|
| 154 |
- #' x_at = c(0.5, 1, 2),+ } |
||
| 155 |
- #' vline = 1,+ |
||
| 156 |
- #' forest_header = c("Hello", "World")
+ #' Conversion of Months to Days |
||
| 157 |
- #' )+ #' |
||
| 158 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 159 |
- #' @export+ #' |
||
| 160 |
- g_forest <- function(tbl,+ #' Conversion of Months to Days. This is an approximative calculation because it |
||
| 161 |
- col_x = attr(tbl, "col_x"),+ #' considers each month as having an average of 30.4375 days. |
||
| 162 |
- col_ci = attr(tbl, "col_ci"),+ #' |
||
| 163 |
- vline = 1,+ #' @param x (`numeric`)\cr time in months. |
||
| 164 |
- forest_header = attr(tbl, "forest_header"),+ #' |
||
| 165 |
- xlim = c(0.1, 10),+ #' @return A `numeric` vector with the time in days. |
||
| 166 |
- logx = TRUE,+ #' |
||
| 167 |
- x_at = c(0.1, 1, 10),+ #' @examples |
||
| 168 |
- width_row_names = lifecycle::deprecated(),+ #' x <- c(13.25, 8.15, 1, 2.834) |
||
| 169 |
- width_columns = NULL,+ #' month2day(x) |
||
| 170 |
- width_forest = lifecycle::deprecated(),+ #' |
||
| 171 |
- lbl_col_padding = 0,+ #' @export |
||
| 172 |
- rel_width_forest = 0.25,+ month2day <- function(x) {
|
||
| 173 | -+ | 1x |
- font_size = 12,+ checkmate::assert_numeric(x) |
| 174 | -+ | 1x |
- col_symbol_size = attr(tbl, "col_symbol_size"),+ x * 30.4375 |
| 175 |
- col = getOption("ggplot2.discrete.colour")[1],
+ } |
||
| 176 |
- ggtheme = NULL,+ |
||
| 177 |
- as_list = FALSE,+ #' Conversion of Days to Months |
||
| 178 |
- gp = lifecycle::deprecated(),+ #' |
||
| 179 |
- draw = lifecycle::deprecated(),+ #' @param x (`numeric`)\cr time in days. |
||
| 180 |
- newpage = lifecycle::deprecated()) {
+ #' |
||
| 181 |
- # Deprecated argument warnings+ #' @return A `numeric` vector with the time in months. |
||
| 182 | -3x | +
- if (lifecycle::is_present(width_row_names)) {
+ #' |
|
| 183 | -! | +
- lifecycle::deprecate_warn(+ #' @examples |
|
| 184 | -! | +
- "0.9.3", "g_forest(width_row_names)", "g_forest(lbl_col_padding)",+ #' x <- c(403, 248, 30, 86) |
|
| 185 | -! | +
- details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter."+ #' day2month(x) |
|
| 186 |
- )+ #' |
||
| 187 |
- }+ #' @export |
||
| 188 | -3x | +
- if (lifecycle::is_present(width_forest)) {
+ day2month <- function(x) {
|
|
| 189 | -! | +19x |
- lifecycle::deprecate_warn(+ checkmate::assert_numeric(x) |
| 190 | -! | +19x |
- "0.9.3", "g_forest(width_forest)", "g_forest(rel_width_forest)",+ x / 30.4375 |
| 191 | -! | +
- details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter."+ } |
|
| 192 |
- )+ |
||
| 193 |
- }+ #' Return an empty numeric if all elements are `NA`. |
||
| 194 | -3x | +
- if (lifecycle::is_present(gp)) {
+ #' |
|
| 195 | -! | +
- lifecycle::deprecate_warn(+ #' @param x (`numeric`)\cr vector. |
|
| 196 | -! | +
- "0.9.3", "g_forest(gp)", "g_forest(ggtheme)",+ #' |
|
| 197 | -! | +
- details = paste(+ #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`. |
|
| 198 | -! | +
- "`g_forest` is now generated as a `ggplot` object.",+ #' |
|
| 199 | -! | +
- "Additional display settings should be supplied via the `ggtheme` parameter."+ #' @examples |
|
| 200 |
- )+ #' x <- c(NA, NA, NA) |
||
| 201 |
- )+ #' # Internal function - empty_vector_if_na |
||
| 202 |
- }+ #' @keywords internal |
||
| 203 | -3x | +
- if (lifecycle::is_present(draw)) {
+ empty_vector_if_na <- function(x) {
|
|
| 204 | -! | +683x |
- lifecycle::deprecate_warn(+ if (all(is.na(x))) {
|
| 205 | -! | +220x |
- "0.9.3", "g_forest(draw)",+ numeric() |
| 206 | -! | +
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."+ } else {
|
|
| 207 | -+ | 463x |
- )+ x |
| 209 | -3x | +
- if (lifecycle::is_present(newpage)) {
+ } |
|
| 210 | -! | +
- lifecycle::deprecate_warn(+ |
|
| 211 | -! | +
- "0.9.3", "g_forest(newpage)",+ #' Combine Two Vectors Element Wise |
|
| 212 | -! | +
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."+ #' |
|
| 213 |
- )+ #' @param x (`vector`)\cr first vector to combine. |
||
| 214 |
- }+ #' @param y (`vector`)\cr second vector to combine. |
||
| 215 |
-
+ #' |
||
| 216 | -3x | +
- checkmate::assert_class(tbl, "VTableTree")+ #' @return A `list` where each element combines corresponding elements of `x` and `y`. |
|
| 217 | -3x | +
- checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ #' |
|
| 218 | -3x | +
- checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ #' @examples |
|
| 219 | -3x | +
- checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ #' combine_vectors(1:3, 4:6) |
|
| 220 | -3x | +
- checkmate::assert_number(font_size, lower = 0)+ #' |
|
| 221 | -3x | +
- checkmate::assert_character(col, null.ok = TRUE)+ #' @export |
|
| 222 | -3x | +
- checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl))+ combine_vectors <- function(x, y) {
|
|
| 223 | -+ | 70x |
-
+ checkmate::assert_vector(x) |
| 224 | -+ | 70x |
- # Extract info from table+ checkmate::assert_vector(y, len = length(x)) |
| 225 | -3x | +
- mat <- matrix_form(tbl)+ |
|
| 226 | -3x | +70x |
- mat_strings <- formatters::mf_strings(mat)+ result <- lapply(as.data.frame(rbind(x, y)), `c`) |
| 227 | -3x | +70x |
- nlines_hdr <- formatters::mf_nlheader(mat)+ names(result) <- NULL |
| 228 | -3x | +70x |
- nrows_body <- nrow(mat_strings) - nlines_hdr+ result |
| 229 | -3x | +
- tbl_stats <- mat_strings[nlines_hdr, -1]+ } |
|
| 231 |
- # Generate and modify table as ggplot object+ #' Extract Elements by Name |
||
| 232 | -3x | +
- gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) ++ #' |
|
| 233 | -3x | +
- theme(plot.margin = margin(0, 0, 0, 0.025, "npc"))+ #' This utility function extracts elements from a vector `x` by `names`. |
|
| 234 | -3x | +
- gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01)+ #' Differences to the standard `[` function are: |
|
| 235 | -3x | +
- gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1+ #' |
|
| 236 | -3x | +
- if (nlines_hdr == 2) {
+ #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function). |
|
| 237 | -3x | +
- gg_table$scales$scales[[2]]$expand <- c(0, 0)+ #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those |
|
| 238 | -3x | +
- arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))])+ #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s. |
|
| 239 |
- } else {
+ #' |
||
| 240 | -! | +
- arms <- NULL+ #' @param x (named `vector`)\cr where to extract named elements from. |
|
| 241 |
- }+ #' @param names (`character`)\cr vector of names to extract. |
||
| 242 |
-
+ #' |
||
| 243 | -3x | +
- tbl_df <- as_result_df(tbl)+ #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`. |
|
| 244 | -3x | +
- dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df))+ #' |
|
| 245 | -3x | +
- tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)]+ #' @keywords internal |
|
| 246 | -3x | +
- names(tbl_df) <- c("row_num", tbl_stats)
+ extract_by_name <- function(x, names) {
|
|
| 247 | -+ | 3x |
-
+ if (is.null(x)) {
|
| 248 | -+ | 1x |
- # Check table data columns+ return(NULL) |
| 249 | -3x | +
- if (!is.null(col_ci)) {
+ } |
|
| 250 | -3x | +2x |
- ci_col <- col_ci + 1+ checkmate::assert_named(x) |
| 251 | -+ | 2x |
- } else {
+ checkmate::assert_character(names) |
| 252 | -! | +2x |
- tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df))+ which_extract <- intersect(names(x), names) |
| 253 | -! | +2x |
- ci_col <- which(names(tbl_df) == "empty_ci")+ if (length(which_extract) > 0) {
|
| 254 | -+ | 1x |
- }+ x[which_extract] |
| 255 | -! | +
- if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
+ } else {
|
|
| 256 | -+ | 1x |
-
+ NULL |
| 257 | -3x | +
- if (!is.null(col_x)) {
+ } |
|
| 258 | -3x | +
- x_col <- col_x + 1+ } |
|
| 259 |
- } else {
+
|
||
| 260 | -! | +
- tbl_df[["empty_x"]] <- NA_real_+ #' Labels for Adverse Event Baskets |
|
| 261 | -! | +
- x_col <- which(names(tbl_df) == "empty_x")+ #' |
|
| 262 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 263 | -3x | +
- if (!is.null(col_symbol_size)) {
+ #' |
|
| 264 | -2x | +
- sym_size <- unlist(tbl_df[, col_symbol_size + 1])+ #' @param aesi (`character`)\cr with standardized `MedDRA` query name (e.g. `SMQzzNAM`) or customized query |
|
| 265 |
- } else {
+ #' name (e.g. `CQzzNAM`). |
||
| 266 | -1x | +
- sym_size <- rep(1, nrow(tbl_df))+ #' @param scope (`character`)\cr with scope of query (e.g. `SMQzzSC`). |
|
| 267 |
- }+ #' |
||
| 268 |
-
+ #' @return A `string` with the standard label for the `AE` basket. |
||
| 269 | -3x | +
- tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
+ #' |
|
| 270 | -3x | +
- x <- unlist(tbl_df[, x_col])+ #' @examples |
|
| 271 | -3x | +
- lwr <- unlist(tbl_df[["ci_lwr"]])+ #' adae <- tern_ex_adae |
|
| 272 | -3x | +
- upr <- unlist(tbl_df[["ci_upr"]])+ #' |
|
| 273 | -3x | +
- row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2)+ #' # Standardized query label includes scope. |
|
| 274 |
-
+ #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC) |
||
| 275 | -3x | +
- if (is.null(col)) col <- "#343cff"+ #' |
|
| 276 | -3x | +
- if (length(col) == 1) col <- rep(col, nrow(tbl_df))+ #' # Customized query label. |
|
| 277 | -! | +
- if (is.null(x_at)) x_at <- union(xlim, vline)+ #' aesi_label(adae$CQ01NAM) |
|
| 278 | -3x | +
- x_labels <- x_at+ #' |
|
| 279 |
-
+ #' @export |
||
| 280 |
- # Apply log transformation+ aesi_label <- function(aesi, scope = NULL) {
|
||
| 281 | 3x |
- if (logx) {
+ checkmate::assert_character(aesi) |
|
| 282 | 3x |
- x_t <- log(x)+ checkmate::assert_character(scope, null.ok = TRUE) |
|
| 283 | 3x |
- lwr_t <- log(lwr)+ aesi_label <- obj_label(aesi) |
|
| 284 | 3x |
- upr_t <- log(upr)+ aesi <- sas_na(aesi) |
|
| 285 | 3x |
- xlim_t <- log(xlim)+ aesi <- unique(aesi)[!is.na(unique(aesi))] |
|
| 286 |
- } else {
+
|
||
| 287 | -! | +3x |
- x_t <- x+ lbl <- if (length(aesi) == 1 && !is.null(scope)) {
|
| 288 | -! | +1x |
- lwr_t <- lwr+ scope <- sas_na(scope) |
| 289 | -! | +1x |
- upr_t <- upr+ scope <- unique(scope)[!is.na(unique(scope))] |
| 290 | -! | +1x |
- xlim_t <- xlim+ checkmate::assert_string(scope) |
| 291 | -+ | 1x |
- }+ paste0(aesi, " (", scope, ")")
|
| 292 | -+ | 3x |
-
+ } else if (length(aesi) == 1 && is.null(scope)) {
|
| 293 | -+ | 1x |
- # Set up plot area+ aesi |
| 294 | -3x | +
- gg_plt <- ggplot(data = tbl_df) ++ } else {
|
|
| 295 | -3x | +1x |
- theme(+ aesi_label |
| 296 | -3x | +
- panel.background = element_rect(fill = "transparent", color = NA_character_),+ } |
|
| 297 | -3x | +
- plot.background = element_rect(fill = "transparent", color = NA_character_),+ |
|
| 298 | 3x |
- panel.grid.major = element_blank(),+ lbl |
|
| 299 | -3x | +
- panel.grid.minor = element_blank(),+ } |
|
| 300 | -3x | +
- axis.title.x = element_blank(),+ |
|
| 301 | -3x | +
- axis.title.y = element_blank(),+ #' Indicate Study Arm Variable in Formula |
|
| 302 | -3x | +
- axis.line.x = element_line(),+ #' |
|
| 303 | -3x | +
- axis.text = element_text(size = font_size),+ #' We use `study_arm` to indicate the study arm variable in `tern` formulas. |
|
| 304 | -3x | +
- legend.position = "none",+ #' |
|
| 305 | -3x | +
- plot.margin = margin(0, 0.1, 0.05, 0, "npc")+ #' @param x arm information |
|
| 306 |
- ) ++ #' |
||
| 307 | -3x | +
- scale_x_continuous(+ #' @return `x` |
|
| 308 | -3x | +
- trans = ifelse(logx, "log", "identity"),+ #' |
|
| 309 | -3x | +
- limits = xlim,+ #' @keywords internal |
|
| 310 | -3x | +
- breaks = x_at,+ study_arm <- function(x) {
|
|
| 311 | -3x | +! |
- labels = x_labels,+ structure(x, varname = deparse(substitute(x))) |
| 312 | -3x | +
- expand = c(0.01, 0)+ } |
|
| 313 |
- ) ++ |
||
| 314 | -3x | +
- scale_y_continuous(+ #' Smooth Function with Optional Grouping |
|
| 315 | -3x | +
- limits = c(0, nrow(mat_strings) + 1),+ #' |
|
| 316 | -3x | +
- breaks = NULL,+ #' @description `r lifecycle::badge("stable")`
|
|
| 317 | -3x | +
- expand = c(0, 0)+ #' |
|
| 318 |
- ) ++ #' This produces `loess` smoothed estimates of `y` with Student confidence intervals. |
||
| 319 | -3x | +
- coord_cartesian(clip = "off")+ #' |
|
| 320 |
-
+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
||
| 321 | -3x | +
- if (is.null(ggtheme)) {
+ #' @param x (`character`)\cr value with x column name. |
|
| 322 | -3x | +
- gg_plt <- gg_plt + annotate(+ #' @param y (`character`)\cr value with y column name. |
|
| 323 | -3x | +
- "rect",+ #' @param groups (`character`)\cr vector with optional grouping variables names. |
|
| 324 | -3x | +
- xmin = xlim[1],+ #' @param level (`numeric`)\cr level of confidence interval to use (0.95 by default). |
|
| 325 | -3x | +
- xmax = xlim[2],+ #' |
|
| 326 | -3x | +
- ymin = 0,+ #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and |
|
| 327 | -3x | +
- ymax = nrows_body + 0.5,+ #' optional `groups` variables formatted as `factor` type. |
|
| 328 | -3x | +
- fill = "grey92"+ #' |
|
| 329 |
- )+ #' @export |
||
| 330 |
- }+ get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
|
||
| 331 | -+ | 5x |
-
+ checkmate::assert_data_frame(df) |
| 332 | -3x | +5x |
- if (!is.null(vline)) {
+ df_cols <- colnames(df) |
| 333 | -+ | 5x |
- # Set default forest header+ checkmate::assert_string(x) |
| 334 | -3x | +5x |
- if (is.null(forest_header)) {
+ checkmate::assert_subset(x, df_cols) |
| 335 | -! | +5x |
- forest_header <- c(+ checkmate::assert_numeric(df[[x]]) |
| 336 | -! | +5x |
- paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"),+ checkmate::assert_string(y) |
| 337 | -! | +5x |
- paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n")+ checkmate::assert_subset(y, df_cols) |
| 338 | -+ | 5x |
- )+ checkmate::assert_numeric(df[[y]]) |
| 339 |
- }+ |
||
| 340 | -+ | 5x |
-
+ if (!is.null(groups)) {
|
| 341 | -+ | 4x |
- # Add vline and forest header labels+ checkmate::assert_character(groups) |
| 342 | -3x | +4x |
- mid_pts <- if (logx) {
+ checkmate::assert_subset(groups, df_cols) |
| 343 | -3x | +
- c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2])))))+ } |
|
| 344 |
- } else {
+
|
||
| 345 | -! | +5x |
- c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2])))+ smooths <- function(x, y) {
|
| 346 | -+ | 18x |
- }+ stats::predict(stats::loess(y ~ x), se = TRUE) |
| 347 | -3x | +
- gg_plt <- gg_plt ++ } |
|
| 348 | -3x | +
- annotate(+ |
|
| 349 | -3x | +5x |
- "segment",+ if (!is.null(groups)) {
|
| 350 | -3x | +4x |
- x = vline, xend = vline, y = 0, yend = nrows_body + 0.5+ cc <- stats::complete.cases(df[c(x, y, groups)]) |
| 351 | -+ | 4x |
- ) ++ df_c <- df[cc, c(x, y, groups)] |
| 352 | -3x | +4x |
- annotate(+ df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
|
| 353 | -3x | +4x |
- "text",+ df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups])) |
| 354 | -3x | +
- x = mid_pts[1], y = nrows_body + 1.25,+ |
|
| 355 | -3x | +4x |
- label = forest_header[1],+ df_smooth_raw <- |
| 356 | -3x | +4x |
- size = font_size / .pt,+ by(df_c_ordered, df_c_g, function(d) {
|
| 357 | -3x | +17x |
- lineheight = 0.9+ plx <- smooths(d[[x]], d[[y]]) |
| 358 | -+ | 17x |
- ) ++ data.frame( |
| 359 | -3x | +17x |
- annotate(+ x = d[[x]], |
| 360 | -3x | +17x |
- "text",+ y = plx$fit, |
| 361 | -3x | +17x |
- x = mid_pts[2], y = nrows_body + 1.25,+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se, |
| 362 | -3x | +17x |
- label = forest_header[2],+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se |
| 363 | -3x | +
- size = font_size / .pt,+ ) |
|
| 364 | -3x | +
- lineheight = 0.9+ }) |
|
| 365 |
- )+ |
||
| 366 | -+ | 4x |
- }+ df_smooth <- do.call(rbind, df_smooth_raw) |
| 367 | -+ | 4x |
-
+ df_smooth[groups] <- df_c_g |
| 368 |
- # Add points to plot+ |
||
| 369 | -3x | +4x |
- if (any(!is.na(x_t))) {
+ df_smooth |
| 370 | -3x | +
- x_t[x < xlim[1] | x > xlim[2]] <- NA+ } else {
|
|
| 371 | -3x | +1x |
- gg_plt <- gg_plt + geom_point(+ cc <- stats::complete.cases(df[c(x, y)]) |
| 372 | -3x | +1x |
- x = x_t,+ df_c <- df[cc, ] |
| 373 | -3x | +1x |
- y = row_num,+ plx <- smooths(df_c[[x]], df_c[[y]]) |
| 374 | -3x | +
- color = col,+ |
|
| 375 | -3x | +1x |
- aes(size = sym_size),+ df_smooth <- data.frame( |
| 376 | -3x | +1x |
- na.rm = TRUE+ x = df_c[[x]], |
| 377 | -+ | 1x |
- )+ y = plx$fit, |
| 378 | -+ | 1x |
- }+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se, |
| 379 | -+ | 1x |
-
+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se |
| 380 | -3x | +
- for (i in seq_len(nrow(tbl_df))) {
+ ) |
|
| 381 |
- # Determine which arrow(s) to add to CI lines+ |
||
| 382 | -12x | +1x |
- which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2])+ df_smooth |
| 383 | -12x | +
- which_arrow <- dplyr::case_when(+ } |
|
| 384 | -12x | +
- all(which_arrow) ~ "both",+ } |
|
| 385 | -12x | +
- which_arrow[1] ~ "first",+ |
|
| 386 | -12x | +
- which_arrow[2] ~ "last",+ #' Number of Available (Non-Missing Entries) in a Vector |
|
| 387 | -12x | +
- TRUE ~ NA+ #' |
|
| 388 |
- )+ #' Small utility function for better readability. |
||
| 389 |
-
+ #' |
||
| 390 |
- # Add CI lines+ #' @param x (`any`)\cr vector in which to count non-missing values. |
||
| 391 | -12x | +
- gg_plt <- gg_plt ++ #' |
|
| 392 | -12x | +
- if (!is.na(which_arrow)) {
+ #' @return Number of non-missing values. |
|
| 393 | -10x | +
- annotate(+ #' |
|
| 394 | -10x | +
- "segment",+ #' @keywords internal |
|
| 395 | -10x | +
- x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
+ n_available <- function(x) {
|
|
| 396 | -10x | +258x |
- xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
+ sum(!is.na(x)) |
| 397 | -10x | +
- y = row_num[i], yend = row_num[i],+ } |
|
| 398 | -10x | +
- color = if (length(col) == 1) col else col[i],+ |
|
| 399 | -10x | +
- arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow),+ #' Reapply Variable Labels |
|
| 400 | -10x | +
- na.rm = TRUE+ #' |
|
| 401 |
- )+ #' This is a helper function that is used in tests. |
||
| 402 |
- } else {
+ #' |
||
| 403 | -2x | +
- annotate(+ #' @param x (`vector`)\cr vector of elements that needs new labels. |
|
| 404 | -2x | +
- "segment",+ #' @param varlabels (`character`)\cr vector of labels for `x`. |
|
| 405 | -2x | +
- x = lwr[i], xend = upr[i],+ #' @param ... further parameters to be added to the list. |
|
| 406 | -2x | +
- y = row_num[i], yend = row_num[i],+ #' |
|
| 407 | -2x | +
- color = if (length(col) == 1) col else col[i],+ #' @return `x` with variable labels reapplied. |
|
| 408 | -2x | +
- na.rm = TRUE+ #' |
|
| 409 |
- )+ #' @export |
||
| 410 |
- }+ reapply_varlabels <- function(x, varlabels, ...) {
|
||
| 411 | -+ | 10x |
- }+ named_labels <- c(as.list(varlabels), list(...)) |
| 412 | -+ | 10x |
-
+ formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels) |
| 413 | -+ | 10x |
- # Apply custom ggtheme to plot+ x |
| 414 | -! | +
- if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ } |
|
| 416 | -3x | +
- if (as_list) {
+ # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show |
|
| 417 | -1x | +
- list(+ clogit_with_tryCatch <- function(formula, data, ...) { # nolint
|
|
| 418 | -1x | +30x |
- table = gg_table,+ tryCatch( |
| 419 | -1x | +30x |
- plot = gg_plt+ survival::clogit(formula = formula, data = data, ...), |
| 420 | -+ | 30x |
- )+ error = function(e) stop("model not built successfully with survival::clogit")
|
| 421 |
- } else {
+ ) |
||
| 422 | -2x | +
- cowplot::plot_grid(+ } |
|
| 423 | -2x | +
| 1 | +
- gg_table,+ #' Create a forest plot from an `rtable` |
||
| 424 | -2x | +||
| 2 | +
- gg_plt,+ #' |
||
| 425 | -2x | +||
| 3 | +
- align = "h",+ #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2 |
||
| 426 | -2x | +||
| 4 | +
- axis = "tblr",+ #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The |
||
| 427 | -2x | +||
| 5 | +
- rel_widths = c(1 - rel_width_forest, rel_width_forest)+ #' table and forest plot are printed side-by-side. |
||
| 428 | +6 |
- )+ #' |
|
| 429 | +7 |
- }+ #' @description `r lifecycle::badge("stable")`
|
|
| 430 | +8 |
- }+ #' |
|
| 431 | +9 |
-
+ #' @inheritParams rtable2gg |
|
| 432 | +10 |
- #' Forest Plot Grob+ #' @inheritParams argument_convention |
|
| 433 | +11 |
- #'+ #' @param tbl (`rtable`)\cr table with at least one column with a single value and one column with 2 values. |
|
| 434 | +12 |
- #' @inheritParams g_forest+ #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from |
|
| 435 | +13 |
- #' @param tbl ([rtables::rtable()])+ #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded |
|
| 436 | +14 |
- #' @param x (`numeric`)\cr coordinate of point.+ #' from forest plot. |
|
| 437 | +15 |
- #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval.+ #' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries to get this from |
|
| 438 | +16 |
- #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol.+ #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded |
|
| 439 | +17 |
- #' If `NULL`, the same symbol size is used.+ #' from forest plot. |
|
| 440 | +18 |
- #'+ #' @param vline (`numeric`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. |
|
| 441 | +19 |
- #' @details+ #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively. |
|
| 442 | +20 |
- #' The heights get automatically determined.+ #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute |
|
| 443 | +21 |
- #'+ #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to |
|
| 444 | +22 |
- #' @noRd+ #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not. |
|
| 445 | +23 |
- #'+ #' @param xlim (`numeric`)\cr limits for x axis. |
|
| 446 | +24 |
- #' @examples+ #' @param logx (`flag`)\cr show the x-values on logarithm scale. |
|
| 447 | +25 |
- #' tbl <- rtable(+ #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values. |
|
| 448 | +26 |
- #' header = rheader(+ #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
|
|
| 449 | +27 |
- #' rrow("", "E", rcell("CI", colspan = 2), "N"),
+ #' @param width_columns (`vector` of `numeric`)\cr a vector of column widths. Each element's position in |
|
| 450 | +28 |
- #' rrow("", "A", "B", "C", "D")
+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated |
|
| 451 | +29 |
- #' ),+ #' according to maximum number of characters per column. |
|
| 452 | +30 |
- #' rrow("row 1", 1, 0.8, 1.1, 16),
+ #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
|
|
| 453 | +31 |
- #' rrow("row 2", 1.4, 0.8, 1.6, 25),
+ #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative |
|
| 454 | +32 |
- #' rrow("row 3", 1.2, 0.8, 1.6, 36)
+ #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored. |
|
| 455 | +33 |
- #' )+ #' @param font_size (`numeric`)\cr font size. |
|
| 456 | +34 |
- #'+ #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used |
|
| 457 | +35 |
- #' x <- c(1, 1.4, 1.2)+ #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional |
|
| 458 | +36 |
- #' lower <- c(0.8, 0.8, 0.8)+ #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. |
|
| 459 | +37 |
- #' upper <- c(1.1, 1.6, 1.6)+ #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. |
|
| 460 | +38 |
- #' # numeric vector with multiplication factor to scale each circle radius+ #' @param col (`character`)\cr color(s). |
|
| 461 | +39 |
- #' # default radius is 1/3.5 lines+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
|
| 462 | +40 |
- #' symbol_scale <- c(1, 1.25, 1.5)+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list |
|
| 463 | +41 |
- #'+ #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are |
|
| 464 | +42 |
- #' # Internal function - forest_grob+ #' printed side-by-side via [cowplot::plot_grid()]. |
|
| 465 | +43 |
- #' \donttest{
+ #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
|
| 466 | +44 |
- #' p <- forest_grob(tbl, x, lower, upper,+ #' is no longer used. |
|
| 467 | +45 |
- #' vline = 1, forest_header = c("A", "B"),
+ #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
|
| 468 | +46 |
- #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale,+ #' is no longer used. |
|
| 469 | +47 |
- #' vp = grid::plotViewport(margins = c(1, 1, 1, 1))+ #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
|
| 470 | +48 |
- #' )+ #' is no longer used. |
|
| 471 | +49 |
#' |
|
| 472 | +50 |
- #' draw_grob(p)+ #' @return `ggplot` forest plot and table. |
|
| 473 | +51 |
- #' }+ #' |
|
| 474 | +52 |
- forest_grob <- function(tbl,+ #' @examples |
|
| 475 | +53 |
- x,+ #' library(dplyr) |
|
| 476 | +54 |
- lower,+ #' library(forcats) |
|
| 477 | +55 |
- upper,+ #' library(nestcolor) |
|
| 478 | +56 |
- vline,+ #' |
|
| 479 | +57 |
- forest_header,+ #' adrs <- tern_ex_adrs |
|
| 480 | +58 |
- xlim = NULL,+ #' n_records <- 20 |
|
| 481 | +59 |
- logx = FALSE,+ #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) |
|
| 482 | +60 |
- x_at = NULL,+ #' adrs <- adrs %>% |
|
| 483 | +61 |
- width_row_names = NULL,+ #' filter(PARAMCD == "BESRSPI") %>% |
|
| 484 | +62 |
- width_columns = NULL,+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
|
| 485 | +63 |
- width_forest = grid::unit(1, "null"),+ #' slice(seq_len(n_records)) %>% |
|
| 486 | +64 |
- symbol_size = NULL,+ #' droplevels() %>% |
|
| 487 | +65 |
- col = "blue",+ #' mutate( |
|
| 488 | +66 |
- name = NULL,+ #' # Reorder levels of factor to make the placebo group the reference arm. |
|
| 489 | +67 |
- gp = NULL,+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
|
| 490 | +68 |
- vp = NULL) {
+ #' rsp = AVALC == "CR" |
|
| 491 | -! | +||
| 69 | +
- nr <- nrow(tbl)+ #' ) |
||
| 492 | -! | +||
| 70 | +
- if (is.null(vline)) {
+ #' formatters::var_labels(adrs) <- c(adrs_labels, "Response") |
||
| 493 | -! | +||
| 71 | +
- checkmate::assert_true(is.null(forest_header))+ #' df <- extract_rsp_subgroups( |
||
| 494 | +72 |
- } else {
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
|
|
| 495 | -! | +||
| 73 | +
- checkmate::assert_number(vline)+ #' data = adrs |
||
| 496 | -! | +||
| 74 | +
- checkmate::assert_character(forest_header, len = 2, null.ok = TRUE)+ #' ) |
||
| 497 | +75 |
- }+ #' # Full commonly used response table. |
|
| 498 | +76 |
-
+ #' |
|
| 499 | -! | +||
| 77 | +
- checkmate::assert_numeric(x, len = nr)+ #' tbl <- basic_table() %>% |
||
| 500 | -! | +||
| 78 | +
- checkmate::assert_numeric(lower, len = nr)+ #' tabulate_rsp_subgroups(df) |
||
| 501 | -! | +||
| 79 | +
- checkmate::assert_numeric(upper, len = nr)+ #' g_forest(tbl) |
||
| 502 | -! | +||
| 80 | +
- checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE)+ #' |
||
| 503 | -! | +||
| 81 | +
- checkmate::assert_character(col)+ #' # Odds ratio only table. |
||
| 504 | +82 |
-
+ #' |
|
| 505 | -! | +||
| 83 | +
- if (is.null(symbol_size)) {
+ #' tbl_or <- basic_table() %>% |
||
| 506 | -! | +||
| 84 | +
- symbol_size <- rep(1, nr)+ #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
|
||
| 507 | +85 |
- }+ #' g_forest( |
|
| 508 | +86 |
-
+ #' tbl_or, |
|
| 509 | -! | +||
| 87 | +
- if (is.null(xlim)) {
+ #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
|
||
| 510 | -! | +||
| 88 | +
- r <- range(c(x, lower, upper), na.rm = TRUE)+ #' ) |
||
| 511 | -! | +||
| 89 | +
- xlim <- r + c(-0.05, 0.05) * diff(r)+ #' |
||
| 512 | +90 |
- }+ #' # Survival forest plot example. |
|
| 513 | +91 |
-
+ #' adtte <- tern_ex_adtte |
|
| 514 | -! | +||
| 92 | +
- if (logx) {
+ #' # Save variable labels before data processing steps. |
||
| 515 | -! | +||
| 93 | +
- if (is.null(x_at)) {
+ #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) |
||
| 516 | -! | +||
| 94 | +
- x_at <- pretty(log(stats::na.omit(c(x, lower, upper))))+ #' adtte_f <- adtte %>% |
||
| 517 | -! | +||
| 95 | +
- x_labels <- exp(x_at)+ #' filter( |
||
| 518 | +96 |
- } else {
+ #' PARAMCD == "OS", |
|
| 519 | -! | +||
| 97 | +
- x_labels <- x_at+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 520 | -! | +||
| 98 | +
- x_at <- log(x_at)+ #' SEX %in% c("M", "F")
|
||
| 521 | +99 |
- }+ #' ) %>% |
|
| 522 | -! | +||
| 100 | +
- xlim <- log(xlim)+ #' mutate( |
||
| 523 | -! | +||
| 101 | +
- x <- log(x)+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 524 | -! | +||
| 102 | +
- lower <- log(lower)+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 525 | -! | +||
| 103 | +
- upper <- log(upper)+ #' SEX = droplevels(SEX), |
||
| 526 | -! | +||
| 104 | +
- if (!is.null(vline)) {
+ #' AVALU = as.character(AVALU), |
||
| 527 | -! | +||
| 105 | +
- vline <- log(vline)+ #' is_event = CNSR == 0 |
||
| 528 | +106 |
- }+ #' ) |
|
| 529 | +107 |
- } else {
+ #' labels <- list( |
|
| 530 | -! | +||
| 108 | +
- x_labels <- TRUE+ #' "ARM" = adtte_labels["ARM"], |
||
| 531 | +109 |
- }+ #' "SEX" = adtte_labels["SEX"], |
|
| 532 | +110 |
-
+ #' "AVALU" = adtte_labels["AVALU"], |
|
| 533 | -! | +||
| 111 | +
- data_forest_vp <- grid::dataViewport(xlim, c(0, 1))+ #' "is_event" = "Event Flag" |
||
| 534 | +112 |
-
+ #' ) |
|
| 535 | +113 |
- # Get table content as matrix form.+ #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) |
|
| 536 | -! | +||
| 114 | +
- mf <- matrix_form(tbl)+ #' df <- extract_survival_subgroups( |
||
| 537 | +115 |
-
+ #' variables = list( |
|
| 538 | +116 |
- # Use `rtables` indent_string eventually.+ #' tte = "AVAL", |
|
| 539 | -! | +||
| 117 | +
- mf$strings[, 1] <- paste0(+ #' is_event = "is_event", |
||
| 540 | -! | +||
| 118 | +
- strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
- |
- ||
| 541 | -! | -
- mf$strings[, 1]+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
|
| 542 | +119 |
- )+ #' ), |
|
| 543 | +120 | - - | -|
| 544 | -! | -
- n_header <- attr(mf, "nrow_header")+ #' data = adtte_f |
|
| 545 | +121 |
-
+ #' ) |
|
| 546 | -! | +||
| 122 | +
- if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
+ #' table_hr <- basic_table() %>% |
||
| 547 | +123 |
-
+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
|
| 548 | +124 |
- # Pre-process the data to be used in lapply and cell_in_rows.+ #' g_forest(table_hr) |
|
| 549 | -! | +||
| 125 | +
- to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
+ #' |
||
| 550 | -! | +||
| 126 | +
- underline_colspan = FALSE) {
+ #' # Works with any `rtable`. |
||
| 551 | -! | +||
| 127 | +
- part <- match.arg(part)+ #' tbl <- rtable( |
||
| 552 | -! | +||
| 128 | +
- if (part == "body") {
+ #' header = c("E", "CI", "N"),
|
||
| 553 | -! | +||
| 129 | +
- mat_row_indices <- seq_len(nrow(tbl)) + n_header+ #' rrow("", 1, c(.8, 1.2), 200),
|
||
| 554 | -! | +||
| 130 | +
- row_ind_offset <- -n_header+ #' rrow("", 1.2, c(1.1, 1.4), 50)
|
||
| 555 | +131 |
- } else {
+ #' ) |
|
| 556 | -! | +||
| 132 | +
- mat_row_indices <- seq_len(n_header)+ #' g_forest( |
||
| 557 | -! | +||
| 133 | +
- row_ind_offset <- 0+ #' tbl = tbl, |
||
| 558 | +134 |
- }+ #' col_x = 1, |
|
| 559 | +135 |
-
+ #' col_ci = 2, |
|
| 560 | -! | +||
| 136 | +
- lapply(mat_row_indices, function(i) {
+ #' xlim = c(0.5, 2), |
||
| 561 | -! | +||
| 137 | +
- disp <- mf$display[i, -1]+ #' x_at = c(0.5, 1, 2), |
||
| 562 | -! | +||
| 138 | +
- list(+ #' col_symbol_size = 3 |
||
| 563 | -! | +||
| 139 | +
- row_name = mf$strings[i, 1],+ #' ) |
||
| 564 | -! | +||
| 140 | +
- cells = mf$strings[i, -1][disp],+ #' |
||
| 565 | -! | +||
| 141 | +
- cell_spans = mf$spans[i, -1][disp],+ #' tbl <- rtable( |
||
| 566 | -! | +||
| 142 | +
- row_index = i + row_ind_offset,+ #' header = rheader( |
||
| 567 | -! | +||
| 143 | +
- underline_colspan = underline_colspan+ #' rrow("", rcell("A", colspan = 2)),
|
||
| 568 | +144 |
- )+ #' rrow("", "c1", "c2")
|
|
| 569 | +145 |
- })+ #' ), |
|
| 570 | +146 |
- }+ #' rrow("row 1", 1, c(.8, 1.2)),
|
|
| 571 | +147 |
-
+ #' rrow("row 2", 1.2, c(1.1, 1.4))
|
|
| 572 | -! | +||
| 148 | +
- args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
+ #' ) |
||
| 573 | -! | +||
| 149 | +
- args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
+ #' g_forest( |
||
| 574 | +150 |
-
+ #' tbl = tbl, |
|
| 575 | -! | +||
| 151 | +
- grid::gTree(+ #' col_x = 1, |
||
| 576 | -! | +||
| 152 | +
- name = name,+ #' col_ci = 2, |
||
| 577 | -! | +||
| 153 | +
- children = grid::gList(+ #' xlim = c(0.5, 2), |
||
| 578 | -! | +||
| 154 | +
- grid::gTree(+ #' x_at = c(0.5, 1, 2), |
||
| 579 | -! | +||
| 155 | +
- children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)),+ #' vline = 1, |
||
| 580 | -! | +||
| 156 | +
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ #' forest_header = c("Hello", "World")
|
||
| 581 | +157 |
- ),+ #' ) |
|
| 582 | -! | +||
| 158 | +
- grid::gTree(+ #' |
||
| 583 | -! | +||
| 159 | +
- children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)),+ #' @export |
||
| 584 | -! | +||
| 160 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ g_forest <- function(tbl, |
||
| 585 | +161 |
- ),+ col_x = attr(tbl, "col_x"), |
|
| 586 | -! | +||
| 162 | +
- grid::linesGrob(+ col_ci = attr(tbl, "col_ci"), |
||
| 587 | -! | +||
| 163 | +
- grid::unit(c(0, 1), "npc"),+ vline = 1, |
||
| 588 | -! | +||
| 164 | +
- y = grid::unit(c(.5, .5), "npc"),+ forest_header = attr(tbl, "forest_header"), |
||
| 589 | -! | +||
| 165 | +
- vp = grid::vpPath("vp_table_layout", "vp_spacer")
+ xlim = c(0.1, 10), |
||
| 590 | +166 |
- ),+ logx = TRUE, |
|
| 591 | +167 |
- # forest part+ x_at = c(0.1, 1, 10), |
|
| 592 | -! | +||
| 168 | +
- if (is.null(vline)) {
+ width_row_names = lifecycle::deprecated(), |
||
| 593 | -! | +||
| 169 | +
- NULL+ width_columns = NULL, |
||
| 594 | +170 |
- } else {
+ width_forest = lifecycle::deprecated(), |
|
| 595 | -! | +||
| 171 | +
- grid::gTree(+ lbl_col_padding = 0, |
||
| 596 | -! | +||
| 172 | +
- children = grid::gList(+ rel_width_forest = 0.25, |
||
| 597 | -! | +||
| 173 | +
- grid::gTree(+ font_size = 12, |
||
| 598 | -! | +||
| 174 | +
- children = grid::gList(+ col_symbol_size = attr(tbl, "col_symbol_size"), |
||
| 599 | +175 |
- # this may overflow, to fix, look here+ col = getOption("ggplot2.discrete.colour")[1],
|
|
| 600 | +176 |
- # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint+ ggtheme = NULL, |
|
| 601 | -! | +||
| 177 | +
- grid::textGrob(+ as_list = FALSE, |
||
| 602 | -! | +||
| 178 | +
- forest_header[1],+ gp = lifecycle::deprecated(), |
||
| 603 | -! | +||
| 179 | +
- x = grid::unit(vline, "native") - grid::unit(1, "lines"),+ draw = lifecycle::deprecated(), |
||
| 604 | -! | +||
| 180 | +
- just = c("right", "center")
+ newpage = lifecycle::deprecated()) {
|
||
| 605 | +181 |
- ),+ # Deprecated argument warnings |
|
| 606 | -! | +||
| 182 | +3x |
- grid::textGrob(+ if (lifecycle::is_present(width_row_names)) {
|
|
| 607 | +183 | ! |
- forest_header[2],+ lifecycle::deprecate_warn( |
| 608 | +184 | ! |
- x = grid::unit(vline, "native") + grid::unit(1, "lines"),+ "0.9.3", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", |
| 609 | +185 | ! |
- just = c("left", "center")
+ details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." |
| 610 | +186 |
- )+ ) |
|
| 611 | +187 |
- ),+ } |
|
| 612 | -! | +||
| 188 | +3x |
- vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp)+ if (lifecycle::is_present(width_forest)) {
|
|
| 613 | -+ | ||
| 189 | +! |
- )+ lifecycle::deprecate_warn( |
|
| 614 | -+ | ||
| 190 | +! |
- ),+ "0.9.3", "g_forest(width_forest)", "g_forest(rel_width_forest)", |
|
| 615 | +191 | ! |
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." |
| 616 | +192 |
- )+ ) |
|
| 617 | +193 |
- },+ } |
|
| 618 | -! | +||
| 194 | +3x |
- grid::gTree(+ if (lifecycle::is_present(gp)) {
|
|
| 619 | +195 | ! |
- children = grid::gList(+ lifecycle::deprecate_warn( |
| 620 | +196 | ! |
- grid::gTree(+ "0.9.3", "g_forest(gp)", "g_forest(ggtheme)", |
| 621 | +197 | ! |
- children = grid::gList(+ details = paste( |
| 622 | +198 | ! |
- grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")),+ "`g_forest` is now generated as a `ggplot` object.", |
| 623 | +199 | ! |
- if (is.null(vline)) {
+ "Additional display settings should be supplied via the `ggtheme` parameter." |
| 624 | -! | +||
| 200 | +
- NULL+ ) |
||
| 625 | +201 |
- } else {
+ ) |
|
| 626 | -! | +||
| 202 | +
- grid::linesGrob(+ } |
||
| 627 | -! | +||
| 203 | +3x |
- x = grid::unit(rep(vline, 2), "native"),+ if (lifecycle::is_present(draw)) {
|
|
| 628 | +204 | ! |
- y = grid::unit(c(0, 1), "npc"),+ lifecycle::deprecate_warn( |
| 629 | +205 | ! |
- gp = grid::gpar(lwd = 2),+ "0.9.3", "g_forest(draw)", |
| 630 | +206 | ! |
- vp = data_forest_vp+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
| 631 | +207 |
- )+ ) |
|
| 632 | +208 |
- },+ }+ |
+ |
| 209 | +3x | +
+ if (lifecycle::is_present(newpage)) {
|
|
| 633 | +210 | ! |
- grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp)+ lifecycle::deprecate_warn( |
| 634 | -+ | ||
| 211 | +! |
- ),+ "0.9.3", "g_forest(newpage)", |
|
| 635 | +212 | ! |
- vp = grid::viewport(layout.pos.col = ncol(tbl) + 2)+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
| 636 | +213 |
- )+ ) |
|
| 637 | +214 |
- ),- |
- |
| 638 | -! | -
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ } |
|
| 639 | +215 |
- ),+ |
|
| 640 | -! | +||
| 216 | +3x |
- grid::gTree(+ checkmate::assert_class(tbl, "VTableTree") |
|
| 641 | -! | +||
| 217 | +3x |
- children = do.call(+ checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
|
| 642 | -! | +||
| 218 | +3x |
- grid::gList,+ checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
|
| 643 | -! | +||
| 219 | +3x |
- Map(+ checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
|
| 644 | -! | +||
| 220 | +3x |
- function(xi, li, ui, row_index, size_i, col) {
+ checkmate::assert_number(font_size, lower = 0) |
|
| 645 | -! | +||
| 221 | +3x |
- forest_dot_line(+ checkmate::assert_character(col, null.ok = TRUE) |
|
| 646 | -! | +||
| 222 | +3x |
- xi,+ checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl)) |
|
| 647 | -! | +||
| 223 | +
- li,+ |
||
| 648 | -! | +||
| 224 | +
- ui,+ # Extract info from table |
||
| 649 | -! | +||
| 225 | +3x |
- row_index,+ mat <- matrix_form(tbl) |
|
| 650 | -! | +||
| 226 | +3x |
- xlim,+ mat_strings <- formatters::mf_strings(mat) |
|
| 651 | -! | +||
| 227 | +3x |
- symbol_size = size_i,+ nlines_hdr <- formatters::mf_nlheader(mat) |
|
| 652 | -! | +||
| 228 | +3x |
- col = col,+ nrows_body <- nrow(mat_strings) - nlines_hdr |
|
| 653 | -! | +||
| 229 | +3x |
- datavp = data_forest_vp+ tbl_stats <- mat_strings[nlines_hdr, -1] |
|
| 654 | +230 |
- )+ |
|
| 655 | +231 |
- },- |
- |
| 656 | -! | -
- x,+ # Generate and modify table as ggplot object |
|
| 657 | -! | +||
| 232 | +3x |
- lower,+ gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + |
|
| 658 | -! | +||
| 233 | +3x |
- upper,+ theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) |
|
| 659 | -! | +||
| 234 | +3x |
- seq_along(x),+ gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) |
|
| 660 | -! | +||
| 235 | +3x |
- symbol_size,+ gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 |
|
| 661 | -! | +||
| 236 | +3x |
- col,+ if (nlines_hdr == 2) {
|
|
| 662 | -! | +||
| 237 | +3x |
- USE.NAMES = FALSE+ gg_table$scales$scales[[2]]$expand <- c(0, 0) |
|
| 663 | -+ | ||
| 238 | +3x |
- )+ arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) |
|
| 664 | +239 |
- ),+ } else {
|
|
| 665 | +240 | ! |
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ arms <- NULL |
| 666 | +241 |
- )+ } |
|
| 667 | +242 |
- ),- |
- |
| 668 | -! | -
- childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ |
|
| 669 | -! | +||
| 243 | +3x |
- vp = vp,+ tbl_df <- as_result_df(tbl) |
|
| 670 | -! | +||
| 244 | +3x |
- gp = gp+ dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) |
|
| 671 | -+ | ||
| 245 | +3x |
- )+ tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] |
|
| 672 | -+ | ||
| 246 | +3x |
- }+ names(tbl_df) <- c("row_num", tbl_stats)
|
|
| 673 | +247 | ||
| 674 | -- |
- cell_in_rows <- function(row_name,- |
- |
| 675 | +248 |
- cells,+ # Check table data columns |
|
| 676 | -+ | ||
| 249 | +3x |
- cell_spans,+ if (!is.null(col_ci)) {
|
|
| 677 | -+ | ||
| 250 | +3x |
- row_index,+ ci_col <- col_ci + 1 |
|
| 678 | +251 |
- underline_colspan = FALSE) {
- |
- |
| 679 | -! | -
- checkmate::assert_string(row_name)+ } else {
|
|
| 680 | +252 | ! |
- checkmate::assert_character(cells, min.len = 1, any.missing = FALSE)+ tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) |
| 681 | +253 | ! |
- checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE)+ ci_col <- which(names(tbl_df) == "empty_ci") |
| 682 | -! | +||
| 254 | +
- checkmate::assert_number(row_index)+ } |
||
| 683 | +255 | ! |
- checkmate::assert_flag(underline_colspan)+ if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
|
| 684 | +256 | ||
| 685 | -! | -
- vp_name_rn <- paste0("rowname-", row_index)
- |
- |
| 686 | -! | +||
| 257 | +3x |
- g_rowname <- if (!is.null(row_name) && row_name != "") {
+ if (!is.null(col_x)) {
|
|
| 687 | -! | +||
| 258 | +3x |
- grid::textGrob(+ x_col <- col_x + 1 |
|
| 688 | -! | +||
| 259 | +
- name = vp_name_rn,+ } else {
|
||
| 689 | +260 | ! |
- label = row_name,+ tbl_df[["empty_x"]] <- NA_real_ |
| 690 | +261 | ! |
- x = grid::unit(0, "npc"),+ x_col <- which(names(tbl_df) == "empty_x") |
| 691 | -! | +||
| 262 | +
- just = c("left", "center"),
+ } |
||
| 692 | -! | +||
| 263 | +3x |
- vp = grid::vpPath(paste0("rowname-", row_index))
+ if (!is.null(col_symbol_size)) {
|
|
| 693 | -+ | ||
| 264 | +2x |
- )+ sym_size <- unlist(tbl_df[, col_symbol_size + 1]) |
|
| 694 | +265 |
} else {
|
|
| 695 | -! | +||
| 266 | +1x |
- NULL+ sym_size <- rep(1, nrow(tbl_df)) |
|
| 696 | +267 |
} |
|
| 697 | +268 | ||
| 698 | -! | +||
| 269 | +3x |
- gl_cols <- if (!(length(cells) > 0)) {
+ tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
|
|
| 699 | -! | +||
| 270 | +3x |
- list(NULL)+ x <- unlist(tbl_df[, x_col]) |
|
| 700 | -+ | ||
| 271 | +3x |
- } else {
+ lwr <- unlist(tbl_df[["ci_lwr"]]) |
|
| 701 | -! | +||
| 272 | +3x |
- j <- 1 # column index of cell+ upr <- unlist(tbl_df[["ci_upr"]]) |
|
| 702 | -- | - - | -|
| 703 | -! | +||
| 273 | +3x |
- lapply(seq_along(cells), function(k) {
+ row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) |
|
| 704 | -! | +||
| 274 | +
- cell_ascii <- cells[[k]]+ |
||
| 705 | -! | +||
| 275 | +3x |
- cs <- cell_spans[[k]]+ if (is.null(col)) col <- "#343cff" |
|
| 706 | -+ | ||
| 276 | +3x |
-
+ if (length(col) == 1) col <- rep(col, nrow(tbl_df)) |
|
| 707 | +277 | ! |
- if (is.na(cell_ascii) || is.null(cell_ascii)) {
+ if (is.null(x_at)) x_at <- union(xlim, vline) |
| 708 | -! | +||
| 278 | +3x |
- cell_ascii <- "NA"+ x_labels <- x_at |
|
| 709 | +279 |
- }+ |
|
| 710 | +280 |
-
+ # Apply log transformation |
|
| 711 | -! | +||
| 281 | +3x |
- cell_name <- paste0("g-cell-", row_index, "-", j)
+ if (logx) {
|
|
| 712 | -+ | ||
| 282 | +3x |
-
+ x_t <- log(x) |
|
| 713 | -! | +||
| 283 | +3x |
- cell_grobs <- if (identical(cell_ascii, "")) {
+ lwr_t <- log(lwr) |
|
| 714 | -! | +||
| 284 | +3x |
- NULL+ upr_t <- log(upr) |
|
| 715 | -+ | ||
| 285 | +3x |
- } else {
+ xlim_t <- log(xlim) |
|
| 716 | -! | +||
| 286 | +
- if (cs == 1) {
+ } else {
|
||
| 717 | +287 | ! |
- grid::textGrob(+ x_t <- x |
| 718 | +288 | ! |
- label = cell_ascii,+ lwr_t <- lwr |
| 719 | +289 | ! |
- name = cell_name,+ upr_t <- upr |
| 720 | +290 | ! |
- vp = grid::vpPath(paste0("cell-", row_index, "-", j))
+ xlim_t <- xlim |
| 721 | +291 |
- )+ } |
|
| 722 | +292 |
- } else {
+
|
|
| 723 | +293 |
- # +1 because of rowname+ # Set up plot area |
|
| 724 | -! | +||
| 294 | +3x |
- vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs))+ gg_plt <- ggplot(data = tbl_df) + |
|
| 725 | -+ | ||
| 295 | +3x |
-
+ theme( |
|
| 726 | -! | +||
| 296 | +3x |
- lab <- grid::textGrob(+ panel.background = element_rect(fill = "transparent", color = NA_character_), |
|
| 727 | -! | +||
| 297 | +3x |
- label = cell_ascii,+ plot.background = element_rect(fill = "transparent", color = NA_character_), |
|
| 728 | -! | +||
| 298 | +3x |
- name = cell_name,+ panel.grid.major = element_blank(), |
|
| 729 | -! | +||
| 299 | +3x |
- vp = vp_joined_cols+ panel.grid.minor = element_blank(), |
|
| 730 | -+ | ||
| 300 | +3x |
- )+ axis.title.x = element_blank(), |
|
| 731 | -+ | ||
| 301 | +3x |
-
+ axis.title.y = element_blank(), |
|
| 732 | -! | +||
| 302 | +3x |
- if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
+ axis.line.x = element_line(), |
|
| 733 | -! | +||
| 303 | +3x |
- lab+ axis.text = element_text(size = font_size), |
|
| 734 | -+ | ||
| 304 | +3x |
- } else {
+ legend.position = "none", |
|
| 735 | -! | +||
| 305 | +3x |
- grid::gList(+ plot.margin = margin(0, 0.1, 0.05, 0, "npc") |
|
| 736 | -! | +||
| 306 | +
- lab,+ ) + |
||
| 737 | -! | +||
| 307 | +3x |
- grid::linesGrob(+ scale_x_continuous( |
|
| 738 | -! | +||
| 308 | +3x |
- x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")),+ trans = ifelse(logx, "log", "identity"), |
|
| 739 | -! | +||
| 309 | +3x |
- y = grid::unit(c(0, 0), "npc"),+ limits = xlim, |
|
| 740 | -! | +||
| 310 | +3x |
- vp = vp_joined_cols+ breaks = x_at, |
|
| 741 | -+ | ||
| 311 | +3x |
- )+ labels = x_labels, |
|
| 742 | -+ | ||
| 312 | +3x |
- )+ expand = c(0.01, 0) |
|
| 743 | +313 |
- }+ ) + |
|
| 744 | -+ | ||
| 314 | +3x |
- }+ scale_y_continuous( |
|
| 745 | -+ | ||
| 315 | +3x |
- }+ limits = c(0, nrow(mat_strings) + 1), |
|
| 746 | -! | +||
| 316 | +3x |
- j <<- j + cs+ breaks = NULL,+ |
+ |
| 317 | +3x | +
+ expand = c(0, 0) |
|
| 747 | +318 |
-
+ ) + |
|
| 748 | -! | +||
| 319 | +3x |
- cell_grobs+ coord_cartesian(clip = "off") |
|
| 749 | +320 |
- })+ |
|
| 750 | -+ | ||
| 321 | +3x |
- }+ if (is.null(ggtheme)) {
|
|
| 751 | -+ | ||
| 322 | +3x |
-
+ gg_plt <- gg_plt + annotate( |
|
| 752 | -! | +||
| 323 | +3x |
- grid::gList(+ "rect", |
|
| 753 | -! | +||
| 324 | +3x |
- g_rowname,+ xmin = xlim[1], |
|
| 754 | -! | +||
| 325 | +3x |
- do.call(grid::gList, gl_cols)+ xmax = xlim[2], |
|
| 755 | -+ | ||
| 326 | +3x |
- )+ ymin = 0, |
|
| 756 | -+ | ||
| 327 | +3x |
- }+ ymax = nrows_body + 0.5, |
|
| 757 | -+ | ||
| 328 | +3x |
-
+ fill = "grey92" |
|
| 758 | +329 |
- #' Graphic Object: Forest Dot Line+ ) |
|
| 759 | +330 |
- #'+ } |
|
| 760 | +331 |
- #' Calculate the `grob` corresponding to the dot line within the forest plot.+ |
|
| 761 | -+ | ||
| 332 | +3x |
- #'+ if (!is.null(vline)) {
|
|
| 762 | +333 |
- #' @noRd+ # Set default forest header |
|
| 763 | -+ | ||
| 334 | +3x |
- forest_dot_line <- function(x,+ if (is.null(forest_header)) {
|
|
| 764 | -+ | ||
| 335 | +! |
- lower,+ forest_header <- c( |
|
| 765 | -+ | ||
| 336 | +! |
- upper,+ paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"), |
|
| 766 | -+ | ||
| 337 | +! |
- row_index,+ paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n") |
|
| 767 | +338 |
- xlim,+ ) |
|
| 768 | +339 |
- symbol_size = 1,+ } |
|
| 769 | +340 |
- col = "blue",+ |
|
| 770 | +341 |
- datavp) {
+ # Add vline and forest header labels |
|
| 771 | -! | +||
| 342 | +3x |
- ci <- c(lower, upper)+ mid_pts <- if (logx) {
|
|
| 772 | -! | +||
| 343 | +3x |
- if (any(!is.na(c(x, ci)))) {
+ c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2]))))) |
|
| 773 | +344 |
- # line+ } else {
|
|
| 774 | +345 | ! |
- y <- grid::unit(c(0.5, 0.5), "npc")+ c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2]))) |
| 775 | +346 |
-
+ } |
|
| 776 | -! | +||
| 347 | +3x |
- g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
+ gg_plt <- gg_plt + |
|
| 777 | -+ | ||
| 348 | +3x |
- # -+ annotate( |
|
| 778 | -! | +||
| 349 | +3x |
- if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
+ "segment", |
|
| 779 | -! | +||
| 350 | +3x |
- grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y)+ x = vline, xend = vline, y = 0, yend = nrows_body + 0.5 |
|
| 780 | -! | +||
| 351 | +
- } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
+ ) + |
||
| 781 | -+ | ||
| 352 | +3x |
- # <->+ annotate( |
|
| 782 | -! | +||
| 353 | +3x |
- grid::linesGrob(+ "text", |
|
| 783 | -! | +||
| 354 | +3x |
- x = grid::unit(xlim, "native"),+ x = mid_pts[1], y = nrows_body + 1.25, |
|
| 784 | -! | +||
| 355 | +3x |
- y = y,+ label = forest_header[1], |
|
| 785 | -! | +||
| 356 | +3x |
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both")+ size = font_size / .pt,+ |
+ |
| 357 | +3x | +
+ lineheight = 0.9 |
|
| 786 | +358 |
- )+ ) + |
|
| 787 | -! | +||
| 359 | +3x |
- } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
+ annotate( |
|
| 788 | -+ | ||
| 360 | +3x |
- # <-+ "text", |
|
| 789 | -! | +||
| 361 | +3x |
- grid::linesGrob(+ x = mid_pts[2], y = nrows_body + 1.25, |
|
| 790 | -! | +||
| 362 | +3x |
- x = grid::unit(c(xlim[1], ci[2]), "native"),+ label = forest_header[2], |
|
| 791 | -! | +||
| 363 | +3x |
- y = y,+ size = font_size / .pt, |
|
| 792 | -! | +||
| 364 | +3x |
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first")+ lineheight = 0.9 |
|
| 793 | +365 |
- )+ ) |
|
| 794 | -! | +||
| 366 | +
- } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
+ } |
||
| 795 | +367 |
- # ->+ |
|
| 796 | -! | +||
| 368 | +
- grid::linesGrob(+ # Add points to plot |
||
| 797 | -! | +||
| 369 | +3x |
- x = grid::unit(c(ci[1], xlim[2]), "native"),+ if (any(!is.na(x_t))) {
|
|
| 798 | -! | +||
| 370 | +3x |
- y = y,+ x_t[x < xlim[1] | x > xlim[2]] <- NA |
|
| 799 | -! | +||
| 371 | +3x |
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last")+ gg_plt <- gg_plt + geom_point( |
|
| 800 | -+ | ||
| 372 | +3x |
- )+ x = x_t, |
|
| 801 | -+ | ||
| 373 | +3x |
- }+ y = row_num, |
|
| 802 | -+ | ||
| 374 | +3x |
- } else {
+ color = col, |
|
| 803 | -! | +||
| 375 | +3x |
- NULL+ aes(size = sym_size),+ |
+ |
| 376 | +3x | +
+ na.rm = TRUE |
|
| 804 | +377 |
- }+ ) |
|
| 805 | +378 |
-
+ } |
|
| 806 | -! | +||
| 379 | +
- g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
+
|
||
| 807 | -! | +||
| 380 | +3x |
- grid::circleGrob(+ for (i in seq_len(nrow(tbl_df))) {
|
|
| 808 | -! | +||
| 381 | +
- x = grid::unit(x, "native"),+ # Determine which arrow(s) to add to CI lines |
||
| 809 | -! | +||
| 382 | +12x |
- y = y,+ which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) |
|
| 810 | -! | +||
| 383 | +12x |
- r = grid::unit(1 / 3.5 * symbol_size, "lines"),+ which_arrow <- dplyr::case_when( |
|
| 811 | -! | +||
| 384 | +12x |
- name = "point"+ all(which_arrow) ~ "both", |
|
| 812 | -+ | ||
| 385 | +12x |
- )+ which_arrow[1] ~ "first", |
|
| 813 | -+ | ||
| 386 | +12x |
- } else {
+ which_arrow[2] ~ "last", |
|
| 814 | -! | +||
| 387 | +12x |
- NULL+ TRUE ~ NA |
|
| 815 | +388 |
- }+ ) |
|
| 816 | +389 | ||
| 817 | -! | +||
| 390 | +
- grid::gTree(+ # Add CI lines |
||
| 818 | -! | +||
| 391 | +12x |
- children = grid::gList(+ gg_plt <- gg_plt + |
|
| 819 | -! | +||
| 392 | +12x |
- grid::gTree(+ if (!is.na(which_arrow)) {
|
|
| 820 | -! | +||
| 393 | +10x |
- children = grid::gList(+ annotate( |
|
| 821 | -! | +||
| 394 | +10x |
- grid::gList(+ "segment", |
|
| 822 | -! | +||
| 395 | +10x |
- g_line,+ x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
|
|
| 823 | -! | +||
| 396 | +10x |
- g_circle+ xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
|
|
| 824 | -+ | ||
| 397 | +10x |
- )+ y = row_num[i], yend = row_num[i], |
|
| 825 | -+ | ||
| 398 | +10x |
- ),+ color = if (length(col) == 1) col else col[i], |
|
| 826 | -! | +||
| 399 | +10x |
- vp = datavp,+ arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow), |
|
| 827 | -! | +||
| 400 | +10x |
- gp = grid::gpar(col = col, fill = col)+ na.rm = TRUE |
|
| 828 | +401 |
) |
|
| 829 | +402 |
- ),+ } else {
|
|
| 830 | -! | +||
| 403 | +2x |
- vp = grid::vpPath(paste0("forest-", row_index))
+ annotate( |
|
| 831 | -+ | ||
| 404 | +2x |
- )+ "segment", |
|
| 832 | -+ | ||
| 405 | +2x |
- } else {
+ x = lwr[i], xend = upr[i], |
|
| 833 | -! | +||
| 406 | +2x |
- NULL+ y = row_num[i], yend = row_num[i], |
|
| 834 | -+ | ||
| 407 | +2x |
- }+ color = if (length(col) == 1) col else col[i], |
|
| 835 | -+ | ||
| 408 | +2x |
- }+ na.rm = TRUE |
|
| 836 | +409 |
-
+ ) |
|
| 837 | +410 |
- #' Create a Viewport Tree for the Forest Plot+ } |
|
| 838 | +411 |
- #' @param tbl (`rtable`)+ } |
|
| 839 | +412 |
- #' @param width_row_names (`grid::unit`)\cr Width of row names+ |
|
| 840 | +413 |
- #' @param width_columns (`grid::unit`)\cr Width of column spans+ # Apply custom ggtheme to plot |
|
| 841 | -+ | ||
| 414 | +! |
- #' @param width_forest (`grid::unit`)\cr Width of the forest plot+ if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
|
| 842 | +415 |
- #' @param gap_column (`grid::unit`)\cr Gap width between the columns+ |
|
| 843 | -+ | ||
| 416 | +3x |
- #' @param gap_header (`grid::unit`)\cr Gap width between the header+ if (as_list) {
|
|
| 844 | -+ | ||
| 417 | +1x |
- #' @param mat_form matrix print form of the table+ list( |
|
| 845 | -+ | ||
| 418 | +1x |
- #' @return A viewport tree.+ table = gg_table, |
|
| 846 | -+ | ||
| 419 | +1x |
- #'+ plot = gg_plt |
|
| 847 | +420 |
- #' @examples+ ) |
|
| 848 | +421 |
- #' library(grid)+ } else {
+ |
+ |
| 422 | +2x | +
+ cowplot::plot_grid(+ |
+ |
| 423 | +2x | +
+ gg_table,+ |
+ |
| 424 | +2x | +
+ gg_plt,+ |
+ |
| 425 | +2x | +
+ align = "h",+ |
+ |
| 426 | +2x | +
+ axis = "tblr",+ |
+ |
| 427 | +2x | +
+ rel_widths = c(1 - rel_width_forest, rel_width_forest) |
|
| 849 | +428 |
- #'+ ) |
|
| 850 | +429 |
- #' tbl <- rtable(+ } |
|
| 851 | +430 |
- #' header = rheader(+ } |
|
| 852 | +431 |
- #' rrow("", "E", rcell("CI", colspan = 2)),
+
|
|
| 853 | +432 |
- #' rrow("", "A", "B", "C")
+ #' Forest Plot Grob |
|
| 854 | +433 |
- #' ),+ #' |
|
| 855 | +434 |
- #' rrow("row 1", 1, 0.8, 1.1),
+ #' @inheritParams g_forest |
|
| 856 | +435 |
- #' rrow("row 2", 1.4, 0.8, 1.6),
+ #' @param tbl ([rtables::rtable()]) |
|
| 857 | +436 |
- #' rrow("row 3", 1.2, 0.8, 1.2)
+ #' @param x (`numeric`)\cr coordinate of point. |
|
| 858 | +437 |
- #' )+ #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval. |
|
| 859 | +438 |
- #'+ #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol. |
|
| 860 | +439 |
- #' \donttest{
+ #' If `NULL`, the same symbol size is used. |
|
| 861 | +440 |
- #' v <- forest_viewport(tbl)+ #' |
|
| 862 | +441 |
- #'+ #' @details |
|
| 863 | +442 |
- #' grid::grid.newpage()+ #' The heights get automatically determined. |
|
| 864 | +443 |
- #' showViewport(v)+ #' |
|
| 865 | +444 |
- #' }+ #' @noRd |
|
| 866 | +445 |
#' |
|
| 867 | +446 |
- #' @export+ #' @examples |
|
| 868 | +447 |
- forest_viewport <- function(tbl,+ #' tbl <- rtable( |
|
| 869 | +448 |
- width_row_names = NULL,+ #' header = rheader( |
|
| 870 | +449 |
- width_columns = NULL,+ #' rrow("", "E", rcell("CI", colspan = 2), "N"),
|
|
| 871 | +450 |
- width_forest = grid::unit(1, "null"),+ #' rrow("", "A", "B", "C", "D")
|
|
| 872 | +451 |
- gap_column = grid::unit(1, "lines"),+ #' ), |
|
| 873 | +452 |
- gap_header = grid::unit(1, "lines"),+ #' rrow("row 1", 1, 0.8, 1.1, 16),
|
|
| 874 | +453 |
- mat_form = NULL) {
+ #' rrow("row 2", 1.4, 0.8, 1.6, 25),
|
|
| 875 | -! | +||
| 454 | +
- lifecycle::deprecate_warn(+ #' rrow("row 3", 1.2, 0.8, 1.6, 36)
|
||
| 876 | -! | +||
| 455 | +
- "0.9.3",+ #' ) |
||
| 877 | -! | +||
| 456 | +
- "forest_viewport()",+ #' |
||
| 878 | -! | +||
| 457 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' x <- c(1, 1.4, 1.2) |
||
| 879 | +458 |
- )+ #' lower <- c(0.8, 0.8, 0.8) |
|
| 880 | +459 |
-
+ #' upper <- c(1.1, 1.6, 1.6) |
|
| 881 | -! | +||
| 460 | +
- checkmate::assert_class(tbl, "VTableTree")+ #' # numeric vector with multiplication factor to scale each circle radius |
||
| 882 | -! | +||
| 461 | +
- checkmate::assert_true(grid::is.unit(width_forest))+ #' # default radius is 1/3.5 lines |
||
| 883 | -! | +||
| 462 | +
- if (!is.null(width_row_names)) {
+ #' symbol_scale <- c(1, 1.25, 1.5) |
||
| 884 | -! | +||
| 463 | +
- checkmate::assert_true(grid::is.unit(width_row_names))+ #' |
||
| 885 | +464 |
- }+ #' # Internal function - forest_grob |
|
| 886 | -! | +||
| 465 | +
- if (!is.null(width_columns)) {
+ #' \donttest{
|
||
| 887 | -! | +||
| 466 | +
- checkmate::assert_true(grid::is.unit(width_columns))+ #' p <- forest_grob(tbl, x, lower, upper, |
||
| 888 | +467 |
- }+ #' vline = 1, forest_header = c("A", "B"),
|
|
| 889 | +468 |
-
+ #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale, |
|
| 890 | -! | +||
| 469 | +
- if (is.null(mat_form)) mat_form <- matrix_form(tbl)+ #' vp = grid::plotViewport(margins = c(1, 1, 1, 1)) |
||
| 891 | +470 |
-
+ #' ) |
|
| 892 | -! | +||
| 471 | +
- mat_form$strings[!mat_form$display] <- ""+ #' |
||
| 893 | +472 |
-
+ #' draw_grob(p) |
|
| 894 | -! | +||
| 473 | +
- nr <- nrow(tbl)+ #' } |
||
| 895 | -! | +||
| 474 | +
- nc <- ncol(tbl)+ forest_grob <- function(tbl, |
||
| 896 | -! | +||
| 475 | +
- nr_h <- attr(mat_form, "nrow_header")+ x, |
||
| 897 | +476 |
-
+ lower, |
|
| 898 | -! | +||
| 477 | +
- if (is.null(width_row_names) || is.null(width_columns)) {
+ upper, |
||
| 899 | -! | +||
| 478 | +
- tbl_widths <- formatters::propose_column_widths(mat_form)+ vline, |
||
| 900 | -! | +||
| 479 | +
- strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
+ forest_header, |
||
| 901 | -! | +||
| 480 | +
- if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ xlim = NULL, |
||
| 902 | -! | +||
| 481 | +
- if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1])+ logx = FALSE, |
||
| 903 | +482 |
- }+ x_at = NULL, |
|
| 904 | +483 |
-
+ width_row_names = NULL, |
|
| 905 | +484 |
- # Widths for row name, cols, forest.+ width_columns = NULL, |
|
| 906 | -! | +||
| 485 | +
- widths <- grid::unit.c(+ width_forest = grid::unit(1, "null"), |
||
| 907 | -! | +||
| 486 | +
- width_row_names + gap_column,+ symbol_size = NULL, |
||
| 908 | -! | +||
| 487 | +
- width_columns + gap_column,+ col = "blue", |
||
| 909 | -! | +||
| 488 | +
- width_forest+ name = NULL, |
||
| 910 | +489 |
- )+ gp = NULL, |
|
| 911 | +490 |
-
+ vp = NULL) {
|
|
| 912 | +491 | ! |
- n_lines_per_row <- apply(+ nr <- nrow(tbl) |
| 913 | +492 | ! |
- X = mat_form$strings,+ if (is.null(vline)) {
|
| 914 | +493 | ! |
- MARGIN = 1,+ checkmate::assert_true(is.null(forest_header)) |
| 915 | -! | +||
| 494 | +
- FUN = function(row) {
+ } else {
|
||
| 916 | +495 | ! |
- tmp <- vapply(+ checkmate::assert_number(vline) |
| 917 | +496 | ! |
- gregexpr("\n", row, fixed = TRUE),
+ checkmate::assert_character(forest_header, len = 2, null.ok = TRUE) |
| 918 | -! | +||
| 497 | +
- attr, numeric(1),+ } |
||
| 919 | -! | +||
| 498 | +
- "match.length"+ |
||
| 920 | +499 | ! |
- ) + 1+ checkmate::assert_numeric(x, len = nr) |
| 921 | +500 | ! |
- max(c(tmp, 1))- |
-
| 922 | -- |
- }+ checkmate::assert_numeric(lower, len = nr) |
|
| 923 | -+ | ||
| 501 | +! |
- )+ checkmate::assert_numeric(upper, len = nr) |
|
| 924 | -+ | ||
| 502 | +! |
-
+ checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE) |
|
| 925 | +503 | ! |
- i_header <- seq_len(nr_h)+ checkmate::assert_character(col) |
| 926 | +504 | ||
| 927 | +505 | ! |
- height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines")+ if (is.null(symbol_size)) {
|
| 928 | +506 | ! |
- height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines")+ symbol_size <- rep(1, nr) |
| 929 | +507 | ++ |
+ }+ |
+
| 508 | |||
| 930 | +509 | ! |
- height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines")+ if (is.null(xlim)) {
|
| 931 | +510 | ! |
- height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines")+ r <- range(c(x, lower, upper), na.rm = TRUE) |
| 932 | -+ | ||
| 511 | +! |
-
+ xlim <- r + c(-0.05, 0.05) * diff(r) |
|
| 933 | -! | +||
| 512 | +
- nc_g <- nc + 2 # number of columns incl. row names and forest+ } |
||
| 934 | +513 | ||
| 935 | +514 | ! |
- vp_tbl <- grid::vpTree(+ if (logx) {
|
| 936 | +515 | ! |
- parent = grid::viewport(+ if (is.null(x_at)) {
|
| 937 | +516 | ! |
- name = "vp_table_layout",+ x_at <- pretty(log(stats::na.omit(c(x, lower, upper)))) |
| 938 | +517 | ! |
- layout = grid::grid.layout(+ x_labels <- exp(x_at)+ |
+
| 518 | ++ |
+ } else {
|
|
| 939 | +519 | ! |
- nrow = 3, ncol = 1,+ x_labels <- x_at |
| 940 | +520 | ! |
- heights = grid::unit.c(height_header, gap_header, height_body)+ x_at <- log(x_at) |
| 941 | +521 |
- )+ } |
|
| 942 | -+ | ||
| 522 | +! |
- ),+ xlim <- log(xlim) |
|
| 943 | +523 | ! |
- children = grid::vpList(+ x <- log(x) |
| 944 | +524 | ! |
- vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),+ lower <- log(lower) |
| 945 | +525 | ! |
- vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),+ upper <- log(upper) |
| 946 | +526 | ! |
- grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1)+ if (!is.null(vline)) {
+ |
+
| 527 | +! | +
+ vline <- log(vline) |
|
| 947 | +528 |
- )+ } |
|
| 948 | +529 |
- )+ } else {
|
|
| 949 | +530 | ! |
- vp_tbl+ x_labels <- TRUE |
| 950 | +531 |
- }+ } |
|
| 951 | +532 | ||
| 952 | -+ | ||
| 533 | +! |
- #' Viewport Forest Plot: Table Part+ data_forest_vp <- grid::dataViewport(xlim, c(0, 1)) |
|
| 953 | +534 |
- #'+ |
|
| 954 | +535 |
- #' Prepares a viewport for the table included in the forest plot.+ # Get table content as matrix form. |
|
| 955 | -+ | ||
| 536 | +! |
- #'+ mf <- matrix_form(tbl) |
|
| 956 | +537 |
- #' @noRd+ |
|
| 957 | +538 |
- vp_forest_table_part <- function(nrow,+ # Use `rtables` indent_string eventually. |
|
| 958 | -+ | ||
| 539 | +! |
- ncol,+ mf$strings[, 1] <- paste0( |
|
| 959 | -+ | ||
| 540 | +! |
- l_row,+ strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
|
|
| 960 | -+ | ||
| 541 | +! |
- l_col,+ mf$strings[, 1] |
|
| 961 | +542 |
- widths,+ ) |
|
| 962 | +543 |
- heights,+ + |
+ |
| 544 | +! | +
+ n_header <- attr(mf, "nrow_header") |
|
| 963 | +545 |
- name) {
+
|
|
| 964 | +546 | ! |
- grid::vpTree(+ if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
|
| 965 | -! | +||
| 547 | +
- grid::viewport(+ |
||
| 966 | -! | +||
| 548 | +
- name = name,+ # Pre-process the data to be used in lapply and cell_in_rows. |
||
| 967 | +549 | ! |
- layout.pos.row = l_row,+ to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
|
| 968 | +550 | ! |
- layout.pos.col = l_col,+ underline_colspan = FALSE) {
|
| 969 | +551 | ! |
- layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)- |
-
| 970 | -- |
- ),+ part <- match.arg(part) |
|
| 971 | +552 | ! |
- children = grid::vpList(+ if (part == "body") {
|
| 972 | +553 | ! |
- do.call(+ mat_row_indices <- seq_len(nrow(tbl)) + n_header |
| 973 | +554 | ! |
- grid::vpList,+ row_ind_offset <- -n_header |
| 974 | -! | +||
| 555 | +
- lapply(+ } else {
|
||
| 975 | +556 | ! |
- seq_len(nrow), function(i) {
+ mat_row_indices <- seq_len(n_header) |
| 976 | +557 | ! |
- grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
- |
-
| 977 | -- |
- }+ row_ind_offset <- 0 |
|
| 978 | +558 |
- )+ } |
|
| 979 | +559 |
- ),+ |
|
| 980 | +560 | ! |
- do.call(+ lapply(mat_row_indices, function(i) {
|
| 981 | +561 | ! |
- grid::vpList,+ disp <- mf$display[i, -1] |
| 982 | +562 | ! |
- apply(+ list( |
| 983 | +563 | ! |
- expand.grid(seq_len(nrow), seq_len(ncol - 2)),+ row_name = mf$strings[i, 1], |
| 984 | +564 | ! |
- 1,+ cells = mf$strings[i, -1][disp], |
| 985 | +565 | ! |
- function(x) {
+ cell_spans = mf$spans[i, -1][disp], |
| 986 | +566 | ! |
- i <- x[1]+ row_index = i + row_ind_offset, |
| 987 | +567 | ! |
- j <- x[2]+ underline_colspan = underline_colspan |
| 988 | -! | +||
| 568 | +
- grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
+ ) |
||
| 989 | +569 |
- }+ }) |
|
| 990 | +570 |
- )+ } |
|
| 991 | +571 |
- ),+ |
|
| 992 | +572 | ! |
- do.call(+ args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
|
| 993 | +573 | ! |
- grid::vpList,+ args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
+ |
+
| 574 | ++ | + | |
| 994 | +575 | ! |
- lapply(+ grid::gTree( |
| 995 | +576 | ! |
- seq_len(nrow),+ name = name, |
| 996 | +577 | ! |
- function(i) {
+ children = grid::gList( |
| 997 | +578 | ! |
- grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
+ grid::gTree( |
| 998 | -+ | ||
| 579 | +! |
- }+ children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)), |
|
| 999 | -+ | ||
| 580 | +! |
- )+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
|
| 1000 | +581 |
- )+ ), |
|
| 1001 | -+ | ||
| 582 | +! |
- )+ grid::gTree( |
|
| 1002 | -+ | ||
| 583 | +! |
- )+ children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)), |
|
| 1003 | -+ | ||
| 584 | +! |
- }+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
|
| 1004 | +585 |
-
+ ), |
|
| 1005 | -+ | ||
| 586 | +! |
- #' Forest Rendering+ grid::linesGrob( |
|
| 1006 | -+ | ||
| 587 | +! |
- #'+ grid::unit(c(0, 1), "npc"), |
|
| 1007 | -+ | ||
| 588 | +! |
- #' Renders the forest grob.+ y = grid::unit(c(.5, .5), "npc"), |
|
| 1008 | -+ | ||
| 589 | +! |
- #'+ vp = grid::vpPath("vp_table_layout", "vp_spacer")
|
|
| 1009 | +590 |
- #' @noRd+ ), |
|
| 1010 | +591 |
- grid.forest <- function(...) { # nolint
+ # forest part |
|
| 1011 | +592 | ! |
- grid::grid.draw(forest_grob(...))+ if (is.null(vline)) {
|
| 1012 | -+ | ||
| 593 | +! |
- }+ NULL |
| 1 | +594 |
- #' Estimation of Proportions+ } else {
|
|
| 2 | -+ | ||
| 595 | +! |
- #'+ grid::gTree( |
|
| 3 | -+ | ||
| 596 | +! |
- #' @description `r lifecycle::badge("stable")`
+ children = grid::gList( |
|
| 4 | -+ | ||
| 597 | +! |
- #'+ grid::gTree( |
|
| 5 | -+ | ||
| 598 | +! |
- #' Estimate the proportion of responders within a studied population.+ children = grid::gList( |
|
| 6 | +599 |
- #'+ # this may overflow, to fix, look here |
|
| 7 | +600 |
- #' @inheritParams prop_strat_wilson+ # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint |
|
| 8 | -+ | ||
| 601 | +! |
- #' @inheritParams argument_convention+ grid::textGrob( |
|
| 9 | -+ | ||
| 602 | +! |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion")`
+ forest_header[1], |
|
| 10 | -+ | ||
| 603 | +! |
- #' to see available statistics for this function.+ x = grid::unit(vline, "native") - grid::unit(1, "lines"), |
|
| 11 | -+ | ||
| 604 | +! |
- #' @param method (`string`)\cr the method used to construct the confidence interval+ just = c("right", "center")
|
|
| 12 | +605 |
- #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,+ ), |
|
| 13 | -+ | ||
| 606 | +! |
- #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.+ grid::textGrob( |
|
| 14 | -+ | ||
| 607 | +! |
- #' @param long (`flag`)\cr a long description is required.+ forest_header[2], |
|
| 15 | -+ | ||
| 608 | +! |
- #'+ x = grid::unit(vline, "native") + grid::unit(1, "lines"), |
|
| 16 | -+ | ||
| 609 | +! |
- #' @seealso [h_proportions]+ just = c("left", "center")
|
|
| 17 | +610 |
- #'+ ) |
|
| 18 | +611 |
- #' @name estimate_proportions+ ), |
|
| 19 | -+ | ||
| 612 | +! |
- #' @order 1+ vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp) |
|
| 20 | +613 |
- NULL+ ) |
|
| 21 | +614 |
-
+ ), |
|
| 22 | -+ | ||
| 615 | +! |
- #' @describeIn estimate_proportions Statistics function estimating a+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
|
| 23 | +616 |
- #' proportion along with its confidence interval.+ ) |
|
| 24 | +617 |
- #'+ }, |
|
| 25 | -+ | ||
| 618 | +! |
- #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,+ grid::gTree( |
|
| 26 | -+ | ||
| 619 | +! |
- #' it indicates whether each subject is a responder or not. `TRUE` represents+ children = grid::gList( |
|
| 27 | -+ | ||
| 620 | +! |
- #' a successful outcome. If a `data.frame` is provided, also the `strata` variable+ grid::gTree( |
|
| 28 | -+ | ||
| 621 | +! |
- #' names must be provided in `variables` as a list element with the strata strings.+ children = grid::gList( |
|
| 29 | -+ | ||
| 622 | +! |
- #' In the case of `data.frame`, the logical vector of responses must be indicated as a+ grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")), |
|
| 30 | -+ | ||
| 623 | +! |
- #' variable name in `.var`.+ if (is.null(vline)) {
|
|
| 31 | -+ | ||
| 624 | +! |
- #'+ NULL |
|
| 32 | +625 |
- #' @return+ } else {
|
|
| 33 | -+ | ||
| 626 | +! |
- #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a+ grid::linesGrob( |
|
| 34 | -+ | ||
| 627 | +! |
- #' given variable.+ x = grid::unit(rep(vline, 2), "native"), |
|
| 35 | -+ | ||
| 628 | +! |
- #'+ y = grid::unit(c(0, 1), "npc"), |
|
| 36 | -+ | ||
| 629 | +! |
- #' @examples+ gp = grid::gpar(lwd = 2), |
|
| 37 | -+ | ||
| 630 | +! |
- #' # Case with only logical vector.+ vp = data_forest_vp |
|
| 38 | +631 |
- #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)+ ) |
|
| 39 | +632 |
- #' s_proportion(rsp_v)+ }, |
|
| 40 | -+ | ||
| 633 | +! |
- #'+ grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp) |
|
| 41 | +634 |
- #' # Example for Stratified Wilson CI+ ), |
|
| 42 | -+ | ||
| 635 | +! |
- #' nex <- 100 # Number of example rows+ vp = grid::viewport(layout.pos.col = ncol(tbl) + 2) |
|
| 43 | +636 |
- #' dta <- data.frame(+ ) |
|
| 44 | +637 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ ), |
|
| 45 | -+ | ||
| 638 | +! |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
|
| 46 | +639 |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ ), |
|
| 47 | -+ | ||
| 640 | +! |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ grid::gTree( |
|
| 48 | -+ | ||
| 641 | +! |
- #' stringsAsFactors = TRUE+ children = do.call( |
|
| 49 | -+ | ||
| 642 | +! |
- #' )+ grid::gList, |
|
| 50 | -+ | ||
| 643 | +! |
- #'+ Map( |
|
| 51 | -+ | ||
| 644 | +! |
- #' s_proportion(+ function(xi, li, ui, row_index, size_i, col) {
|
|
| 52 | -+ | ||
| 645 | +! |
- #' df = dta,+ forest_dot_line( |
|
| 53 | -+ | ||
| 646 | +! |
- #' .var = "rsp",+ xi, |
|
| 54 | -+ | ||
| 647 | +! |
- #' variables = list(strata = c("f1", "f2")),
+ li, |
|
| 55 | -+ | ||
| 648 | +! |
- #' conf_level = 0.90,+ ui, |
|
| 56 | -+ | ||
| 649 | +! |
- #' method = "strat_wilson"+ row_index, |
|
| 57 | -+ | ||
| 650 | +! |
- #' )+ xlim,+ |
+ |
| 651 | +! | +
+ symbol_size = size_i,+ |
+ |
| 652 | +! | +
+ col = col,+ |
+ |
| 653 | +! | +
+ datavp = data_forest_vp |
|
| 58 | +654 |
- #'+ ) |
|
| 59 | +655 |
- #' @export+ },+ |
+ |
| 656 | +! | +
+ x,+ |
+ |
| 657 | +! | +
+ lower,+ |
+ |
| 658 | +! | +
+ upper,+ |
+ |
| 659 | +! | +
+ seq_along(x),+ |
+ |
| 660 | +! | +
+ symbol_size,+ |
+ |
| 661 | +! | +
+ col,+ |
+ |
| 662 | +! | +
+ USE.NAMES = FALSE |
|
| 60 | +663 |
- s_proportion <- function(df,+ ) |
|
| 61 | +664 |
- .var,+ ),+ |
+ |
| 665 | +! | +
+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
|
| 62 | +666 |
- conf_level = 0.95,+ ) |
|
| 63 | +667 |
- method = c(+ ),+ |
+ |
| 668 | +! | +
+ childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ |
+ |
| 669 | +! | +
+ vp = vp,+ |
+ |
| 670 | +! | +
+ gp = gp |
|
| 64 | +671 |
- "waldcc", "wald", "clopper-pearson",+ ) |
|
| 65 | +672 |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ } |
|
| 66 | +673 |
- "agresti-coull", "jeffreys"+ |
|
| 67 | +674 |
- ),+ cell_in_rows <- function(row_name, |
|
| 68 | +675 |
- weights = NULL,+ cells, |
|
| 69 | +676 |
- max_iterations = 50,+ cell_spans, |
|
| 70 | +677 |
- variables = list(strata = NULL),+ row_index, |
|
| 71 | +678 |
- long = FALSE) {
+ underline_colspan = FALSE) {
|
|
| 72 | -135x | +||
| 679 | +! |
- method <- match.arg(method)+ checkmate::assert_string(row_name) |
|
| 73 | -135x | +||
| 680 | +! |
- checkmate::assert_flag(long)+ checkmate::assert_character(cells, min.len = 1, any.missing = FALSE) |
|
| 74 | -135x | +||
| 681 | +! |
- assert_proportion_value(conf_level)+ checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE) |
|
| 75 | -+ | ||
| 682 | +! |
-
+ checkmate::assert_number(row_index) |
|
| 76 | -135x | +||
| 683 | +! |
- if (!is.null(variables$strata)) {
+ checkmate::assert_flag(underline_colspan) |
|
| 77 | +684 |
- # Checks for strata+ |
|
| 78 | +685 | ! |
- if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
+ vp_name_rn <- paste0("rowname-", row_index)
|
| 79 | +686 | ! |
- strata_colnames <- variables$strata+ g_rowname <- if (!is.null(row_name) && row_name != "") {
|
| 80 | +687 | ! |
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ grid::textGrob( |
| 81 | +688 | ! |
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ name = vp_name_rn, |
| 82 | +689 | ! |
- assert_df_with_variables(df, strata_vars)+ label = row_name, |
| 83 | -+ | ||
| 690 | +! |
-
+ x = grid::unit(0, "npc"), |
|
| 84 | +691 | ! |
- strata <- interaction(df[strata_colnames])+ just = c("left", "center"),
|
| 85 | +692 | ! |
- strata <- as.factor(strata)+ vp = grid::vpPath(paste0("rowname-", row_index))
|
| 86 | +693 |
-
+ ) |
|
| 87 | +694 |
- # Pushing down checks to prop_strat_wilson- |
- |
| 88 | -135x | -
- } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
+ } else {
|
|
| 89 | +695 | ! |
- stop("To use stratified methods you need to specify the strata variables.")
+ NULL |
| 90 | +696 |
} |
|
| 91 | -135x | +||
| 697 | +
- if (checkmate::test_atomic_vector(df)) {
+
|
||
| 92 | -135x | +||
| 698 | +! |
- rsp <- as.logical(df)+ gl_cols <- if (!(length(cells) > 0)) {
+ |
+ |
| 699 | +! | +
+ list(NULL) |
|
| 93 | +700 |
} else {
|
|
| 94 | +701 | ! |
- rsp <- as.logical(df[[.var]])+ j <- 1 # column index of cell |
| 95 | +702 |
- }+ |
|
| 96 | -135x | +||
| 703 | +! |
- n <- sum(rsp)+ lapply(seq_along(cells), function(k) {
|
|
| 97 | -135x | +||
| 704 | +! |
- p_hat <- mean(rsp)+ cell_ascii <- cells[[k]]+ |
+ |
| 705 | +! | +
+ cs <- cell_spans[[k]] |
|
| 98 | +706 | ||
| 99 | -135x | +||
| 707 | +! |
- prop_ci <- switch(method,+ if (is.na(cell_ascii) || is.null(cell_ascii)) {
|
|
| 100 | -135x | +||
| 708 | +! |
- "clopper-pearson" = prop_clopper_pearson(rsp, conf_level),+ cell_ascii <- "NA" |
|
| 101 | -135x | +||
| 709 | +
- "wilson" = prop_wilson(rsp, conf_level),+ } |
||
| 102 | -135x | +||
| 710 | +
- "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),+ |
||
| 103 | -135x | +||
| 711 | +! |
- "strat_wilson" = prop_strat_wilson(rsp,+ cell_name <- paste0("g-cell-", row_index, "-", j)
|
|
| 104 | -135x | +||
| 712 | +
- strata,+ |
||
| 105 | -135x | +||
| 713 | +! |
- weights,+ cell_grobs <- if (identical(cell_ascii, "")) {
|
|
| 106 | -135x | +||
| 714 | +! |
- conf_level,+ NULL |
|
| 107 | -135x | +||
| 715 | +
- max_iterations,+ } else {
|
||
| 108 | -135x | +||
| 716 | +! |
- correct = FALSE+ if (cs == 1) {
|
|
| 109 | -135x | +||
| 717 | +! |
- )$conf_int,+ grid::textGrob( |
|
| 110 | -135x | +||
| 718 | +! |
- "strat_wilsonc" = prop_strat_wilson(rsp,+ label = cell_ascii, |
|
| 111 | -135x | +||
| 719 | +! |
- strata,+ name = cell_name, |
|
| 112 | -135x | +||
| 720 | +! |
- weights,+ vp = grid::vpPath(paste0("cell-", row_index, "-", j))
|
|
| 113 | -135x | +||
| 721 | +
- conf_level,+ ) |
||
| 114 | -135x | +||
| 722 | +
- max_iterations,+ } else {
|
||
| 115 | -135x | +||
| 723 | +
- correct = TRUE+ # +1 because of rowname |
||
| 116 | -135x | +||
| 724 | +! |
- )$conf_int,+ vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs)) |
|
| 117 | -135x | +||
| 725 | +
- "wald" = prop_wald(rsp, conf_level),+ |
||
| 118 | -135x | +||
| 726 | +! |
- "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),+ lab <- grid::textGrob( |
|
| 119 | -135x | +||
| 727 | +! |
- "agresti-coull" = prop_agresti_coull(rsp, conf_level),+ label = cell_ascii, |
|
| 120 | -135x | +||
| 728 | +! |
- "jeffreys" = prop_jeffreys(rsp, conf_level)+ name = cell_name,+ |
+ |
| 729 | +! | +
+ vp = vp_joined_cols |
|
| 121 | +730 |
- )+ ) |
|
| 122 | +731 | ||
| 123 | -135x | +||
| 732 | +! |
- list(+ if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
|
|
| 124 | -135x | +||
| 733 | +! |
- "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),+ lab |
|
| 125 | -135x | +||
| 734 | +
- "prop_ci" = formatters::with_label(+ } else {
|
||
| 126 | -135x | +||
| 735 | +! |
- x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)+ grid::gList( |
|
| 127 | -+ | ||
| 736 | +! |
- )+ lab, |
|
| 128 | -+ | ||
| 737 | +! |
- )+ grid::linesGrob( |
|
| 129 | -+ | ||
| 738 | +! |
- }+ x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")), |
|
| 130 | -+ | ||
| 739 | +! |
-
+ y = grid::unit(c(0, 0), "npc"), |
|
| 131 | -+ | ||
| 740 | +! |
- #' @describeIn estimate_proportions Formatted analysis function which is used as `afun`+ vp = vp_joined_cols |
|
| 132 | +741 |
- #' in `estimate_proportion()`.+ ) |
|
| 133 | +742 |
- #'+ ) |
|
| 134 | +743 |
- #' @return+ } |
|
| 135 | +744 |
- #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
|
| 136 | +745 |
- #'+ } |
|
| 137 | -+ | ||
| 746 | +! |
- #' @export+ j <<- j + cs |
|
| 138 | +747 |
- a_proportion <- make_afun(+ |
|
| 139 | -+ | ||
| 748 | +! |
- s_proportion,+ cell_grobs |
|
| 140 | +749 |
- .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")+ }) |
|
| 141 | +750 |
- )+ } |
|
| 142 | +751 | ||
| 143 | -+ | ||
| 752 | +! |
- #' @describeIn estimate_proportions Layout-creating function which can take statistics function arguments+ grid::gList( |
|
| 144 | -+ | ||
| 753 | +! |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ g_rowname, |
|
| 145 | -+ | ||
| 754 | +! |
- #'+ do.call(grid::gList, gl_cols) |
|
| 146 | +755 |
- #' @return+ ) |
|
| 147 | +756 |
- #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions,+ } |
|
| 148 | +757 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
|
| 149 | +758 |
- #' the statistics from `s_proportion()` to the table layout.+ #' Graphic Object: Forest Dot Line |
|
| 150 | +759 |
#' |
|
| 151 | +760 |
- #' @examples+ #' Calculate the `grob` corresponding to the dot line within the forest plot. |
|
| 152 | +761 |
- #' dta_test <- data.frame(+ #' |
|
| 153 | +762 |
- #' USUBJID = paste0("S", 1:12),
+ #' @noRd |
|
| 154 | +763 |
- #' ARM = rep(LETTERS[1:3], each = 4),+ forest_dot_line <- function(x, |
|
| 155 | +764 |
- #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ lower, |
|
| 156 | +765 |
- #' )+ upper, |
|
| 157 | +766 |
- #'+ row_index, |
|
| 158 | +767 |
- #' basic_table() %>%+ xlim, |
|
| 159 | +768 |
- #' split_cols_by("ARM") %>%
+ symbol_size = 1, |
|
| 160 | +769 |
- #' estimate_proportion(vars = "AVAL") %>%+ col = "blue", |
|
| 161 | +770 |
- #' build_table(df = dta_test)+ datavp) {
|
|
| 162 | -+ | ||
| 771 | +! |
- #'+ ci <- c(lower, upper) |
|
| 163 | -+ | ||
| 772 | +! |
- #' @export+ if (any(!is.na(c(x, ci)))) {
|
|
| 164 | +773 |
- #' @order 2+ # line |
|
| 165 | -+ | ||
| 774 | +! |
- estimate_proportion <- function(lyt,+ y <- grid::unit(c(0.5, 0.5), "npc") |
|
| 166 | +775 |
- vars,+ |
|
| 167 | -+ | ||
| 776 | +! |
- conf_level = 0.95,+ g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
|
|
| 168 | +777 |
- method = c(+ # - |
|
| 169 | -+ | ||
| 778 | +! |
- "waldcc", "wald", "clopper-pearson",+ if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
|
|
| 170 | -+ | ||
| 779 | +! |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y) |
|
| 171 | -+ | ||
| 780 | +! |
- "agresti-coull", "jeffreys"+ } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
|
|
| 172 | +781 |
- ),+ # <-> |
|
| 173 | -+ | ||
| 782 | +! |
- weights = NULL,+ grid::linesGrob( |
|
| 174 | -+ | ||
| 783 | +! |
- max_iterations = 50,+ x = grid::unit(xlim, "native"), |
|
| 175 | -+ | ||
| 784 | +! |
- variables = list(strata = NULL),+ y = y, |
|
| 176 | -+ | ||
| 785 | +! |
- long = FALSE,+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both") |
|
| 177 | +786 |
- na_str = default_na_str(),+ ) |
|
| 178 | -+ | ||
| 787 | +! |
- nested = TRUE,+ } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
|
|
| 179 | +788 |
- ...,+ # <- |
|
| 180 | -+ | ||
| 789 | +! |
- show_labels = "hidden",+ grid::linesGrob( |
|
| 181 | -+ | ||
| 790 | +! |
- table_names = vars,+ x = grid::unit(c(xlim[1], ci[2]), "native"), |
|
| 182 | -+ | ||
| 791 | +! |
- .stats = NULL,+ y = y, |
|
| 183 | -+ | ||
| 792 | +! |
- .formats = NULL,+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first") |
|
| 184 | +793 |
- .labels = NULL,+ )+ |
+ |
| 794 | +! | +
+ } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
|
|
| 185 | +795 |
- .indent_mods = NULL) {
+ # -> |
|
| 186 | -3x | +||
| 796 | +! |
- extra_args <- list(+ grid::linesGrob( |
|
| 187 | -3x | +||
| 797 | +! |
- conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations,+ x = grid::unit(c(ci[1], xlim[2]), "native"), |
|
| 188 | -3x | +||
| 798 | +! |
- variables = variables, long = long, ...+ y = y, |
|
| 189 | -+ | ||
| 799 | +! |
- )+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last") |
|
| 190 | +800 | - - | -|
| 191 | -3x | -
- afun <- make_afun(- |
- |
| 192 | -3x | -
- a_proportion,+ ) |
|
| 193 | -3x | +||
| 801 | +
- .stats = .stats,+ } |
||
| 194 | -3x | +||
| 802 | +
- .formats = .formats,+ } else {
|
||
| 195 | -3x | +||
| 803 | +! |
- .labels = .labels,+ NULL |
|
| 196 | -3x | +||
| 804 | +
- .indent_mods = .indent_mods+ } |
||
| 197 | +805 |
- )+ |
|
| 198 | -3x | +||
| 806 | +! |
- analyze(+ g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
|
|
| 199 | -3x | +||
| 807 | +! |
- lyt,+ grid::circleGrob( |
|
| 200 | -3x | +||
| 808 | +! |
- vars,+ x = grid::unit(x, "native"), |
|
| 201 | -3x | +||
| 809 | +! |
- afun = afun,+ y = y, |
|
| 202 | -3x | +||
| 810 | +! |
- na_str = na_str,+ r = grid::unit(1 / 3.5 * symbol_size, "lines"), |
|
| 203 | -3x | +||
| 811 | +! |
- nested = nested,+ name = "point" |
|
| 204 | -3x | +||
| 812 | +
- extra_args = extra_args,+ ) |
||
| 205 | -3x | +||
| 813 | +
- show_labels = show_labels,+ } else {
|
||
| 206 | -3x | +||
| 814 | +! |
- table_names = table_names+ NULL |
|
| 207 | +815 |
- )+ } |
|
| 208 | +816 |
- }+ |
|
| 209 | -+ | ||
| 817 | +! |
-
+ grid::gTree( |
|
| 210 | -+ | ||
| 818 | +! |
- #' Helper Functions for Calculating Proportion Confidence Intervals+ children = grid::gList( |
|
| 211 | -+ | ||
| 819 | +! |
- #'+ grid::gTree( |
|
| 212 | -+ | ||
| 820 | +! |
- #' @description `r lifecycle::badge("stable")`
+ children = grid::gList( |
|
| 213 | -+ | ||
| 821 | +! |
- #'+ grid::gList( |
|
| 214 | -+ | ||
| 822 | +! |
- #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].+ g_line, |
|
| 215 | -+ | ||
| 823 | +! |
- #'+ g_circle |
|
| 216 | +824 |
- #' @inheritParams argument_convention+ ) |
|
| 217 | +825 |
- #' @inheritParams estimate_proportions+ ), |
|
| 218 | -+ | ||
| 826 | +! |
- #'+ vp = datavp, |
|
| 219 | -+ | ||
| 827 | +! |
- #' @return Confidence interval of a proportion.+ gp = grid::gpar(col = col, fill = col) |
|
| 220 | +828 |
- #'+ ) |
|
| 221 | +829 |
- #' @seealso [estimate_proportions], descriptive function [d_proportion()],+ ), |
|
| 222 | -+ | ||
| 830 | +! |
- #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].+ vp = grid::vpPath(paste0("forest-", row_index))
|
|
| 223 | +831 |
- #'+ ) |
|
| 224 | +832 |
- #' @name h_proportions+ } else {
|
|
| 225 | -+ | ||
| 833 | +! |
- NULL+ NULL |
|
| 226 | +834 |
-
+ } |
|
| 227 | +835 |
- #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()].+ } |
|
| 228 | +836 |
- #' Also referred to as Wilson score interval.+ |
|
| 229 | +837 |
- #'+ #' Create a Viewport Tree for the Forest Plot |
|
| 230 | +838 |
- #' @examples+ #' @param tbl (`rtable`) |
|
| 231 | +839 |
- #' rsp <- c(+ #' @param width_row_names (`grid::unit`)\cr Width of row names |
|
| 232 | +840 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ #' @param width_columns (`grid::unit`)\cr Width of column spans |
|
| 233 | +841 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ #' @param width_forest (`grid::unit`)\cr Width of the forest plot |
|
| 234 | +842 |
- #' )+ #' @param gap_column (`grid::unit`)\cr Gap width between the columns |
|
| 235 | +843 |
- #' prop_wilson(rsp, conf_level = 0.9)+ #' @param gap_header (`grid::unit`)\cr Gap width between the header |
|
| 236 | +844 |
- #'+ #' @param mat_form matrix print form of the table |
|
| 237 | +845 |
- #' @export+ #' @return A viewport tree. |
|
| 238 | +846 |
- prop_wilson <- function(rsp, conf_level, correct = FALSE) {
- |
- |
| 239 | -5x | -
- y <- stats::prop.test(- |
- |
| 240 | -5x | -
- sum(rsp),- |
- |
| 241 | -5x | -
- length(rsp),- |
- |
| 242 | -5x | -
- correct = correct,- |
- |
| 243 | -5x | -
- conf.level = conf_level+ #' |
|
| 244 | +847 |
- )+ #' @examples |
|
| 245 | +848 | - - | -|
| 246 | -5x | -
- as.numeric(y$conf.int)+ #' library(grid) |
|
| 247 | +849 |
- }+ #' |
|
| 248 | +850 |
-
+ #' tbl <- rtable( |
|
| 249 | +851 |
- #' @describeIn h_proportions Calculates the stratified Wilson confidence+ #' header = rheader( |
|
| 250 | +852 |
- #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
+ #' rrow("", "E", rcell("CI", colspan = 2)),
|
|
| 251 | +853 |
- #'+ #' rrow("", "A", "B", "C")
|
|
| 252 | +854 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' ), |
|
| 253 | +855 |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ #' rrow("row 1", 1, 0.8, 1.1),
|
|
| 254 | +856 |
- #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
+ #' rrow("row 2", 1.4, 0.8, 1.6),
|
|
| 255 | +857 |
- #' minimizes the weighted squared length of the confidence interval.+ #' rrow("row 3", 1.2, 0.8, 1.2)
|
|
| 256 | +858 |
- #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ #' ) |
|
| 257 | +859 |
- #' to find estimates of optimal weights.+ #' |
|
| 258 | +860 |
- #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ #' \donttest{
|
|
| 259 | +861 |
- #' [stats::prop.test()].+ #' v <- forest_viewport(tbl) |
|
| 260 | +862 |
#' |
|
| 261 | +863 |
- #' @references+ #' grid::grid.newpage() |
|
| 262 | +864 |
- #' \insertRef{Yan2010-jt}{tern}
+ #' showViewport(v) |
|
| 263 | +865 |
- #'+ #' } |
|
| 264 | +866 |
- #' @examples+ #' |
|
| 265 | +867 |
- #' # Stratified Wilson confidence interval with unequal probabilities+ #' @export |
|
| 266 | +868 |
- #'+ forest_viewport <- function(tbl, |
|
| 267 | +869 |
- #' set.seed(1)+ width_row_names = NULL, |
|
| 268 | +870 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ width_columns = NULL, |
|
| 269 | +871 |
- #' strata_data <- data.frame(+ width_forest = grid::unit(1, "null"), |
|
| 270 | +872 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ gap_column = grid::unit(1, "lines"), |
|
| 271 | +873 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ gap_header = grid::unit(1, "lines"), |
|
| 272 | +874 |
- #' stringsAsFactors = TRUE+ mat_form = NULL) {
|
|
| 273 | -+ | ||
| 875 | +! |
- #' )+ lifecycle::deprecate_warn( |
|
| 274 | -+ | ||
| 876 | +! |
- #' strata <- interaction(strata_data)+ "0.9.3", |
|
| 275 | -+ | ||
| 877 | +! |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ "forest_viewport()", |
|
| 276 | -+ | ||
| 878 | +! |
- #'+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
|
| 277 | +879 |
- #' prop_strat_wilson(+ ) |
|
| 278 | +880 |
- #' rsp = rsp, strata = strata,+ |
|
| 279 | -+ | ||
| 881 | +! |
- #' conf_level = 0.90+ checkmate::assert_class(tbl, "VTableTree") |
|
| 280 | -+ | ||
| 882 | +! |
- #' )+ checkmate::assert_true(grid::is.unit(width_forest)) |
|
| 281 | -+ | ||
| 883 | +! |
- #'+ if (!is.null(width_row_names)) {
|
|
| 282 | -+ | ||
| 884 | +! |
- #' # Not automatic setting of weights+ checkmate::assert_true(grid::is.unit(width_row_names)) |
|
| 283 | +885 |
- #' prop_strat_wilson(+ } |
|
| 284 | -+ | ||
| 886 | +! |
- #' rsp = rsp, strata = strata,+ if (!is.null(width_columns)) {
|
|
| 285 | -+ | ||
| 887 | +! |
- #' weights = rep(1 / n_strata, n_strata),+ checkmate::assert_true(grid::is.unit(width_columns)) |
|
| 286 | +888 |
- #' conf_level = 0.90+ } |
|
| 287 | +889 |
- #' )+ |
|
| 288 | -+ | ||
| 890 | +! |
- #'+ if (is.null(mat_form)) mat_form <- matrix_form(tbl) |
|
| 289 | +891 |
- #' @export+ |
|
| 290 | -+ | ||
| 892 | +! |
- prop_strat_wilson <- function(rsp,+ mat_form$strings[!mat_form$display] <- "" |
|
| 291 | +893 |
- strata,+ |
|
| 292 | -+ | ||
| 894 | +! |
- weights = NULL,+ nr <- nrow(tbl) |
|
| 293 | -+ | ||
| 895 | +! |
- conf_level = 0.95,+ nc <- ncol(tbl) |
|
| 294 | -+ | ||
| 896 | +! |
- max_iterations = NULL,+ nr_h <- attr(mat_form, "nrow_header") |
|
| 295 | +897 |
- correct = FALSE) {
+
|
|
| 296 | -20x | +||
| 898 | +! |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ if (is.null(width_row_names) || is.null(width_columns)) {
|
|
| 297 | -20x | +||
| 899 | +! |
- checkmate::assert_factor(strata, len = length(rsp))+ tbl_widths <- formatters::propose_column_widths(mat_form) |
|
| 298 | -20x | +||
| 900 | +! |
- assert_proportion_value(conf_level)+ strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
|
|
| 299 | -+ | ||
| 901 | +! |
-
+ if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1]) |
|
| 300 | -20x | +||
| 902 | +! |
- tbl <- table(rsp, strata)+ if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1]) |
|
| 301 | -20x | +||
| 903 | +
- n_strata <- length(unique(strata))+ } |
||
| 302 | +904 | ||
| 303 | +905 |
- # Checking the weights and maximum number of iterations.+ # Widths for row name, cols, forest. |
|
| 304 | -20x | +||
| 906 | +! |
- do_iter <- FALSE+ widths <- grid::unit.c( |
|
| 305 | -20x | +||
| 907 | +! |
- if (is.null(weights)) {
+ width_row_names + gap_column, |
|
| 306 | -6x | +||
| 908 | +! |
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ width_columns + gap_column, |
|
| 307 | -6x | +||
| 909 | +! |
- do_iter <- TRUE+ width_forest |
|
| 308 | +910 |
-
+ ) |
|
| 309 | +911 |
- # Iteration parameters- |
- |
| 310 | -2x | -
- if (is.null(max_iterations)) max_iterations <- 10+ |
|
| 311 | -6x | +||
| 912 | +! |
- checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)+ n_lines_per_row <- apply( |
|
| 312 | -+ | ||
| 913 | +! |
- }+ X = mat_form$strings, |
|
| 313 | -20x | +||
| 914 | +! |
- checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata)+ MARGIN = 1, |
|
| 314 | -20x | +||
| 915 | +! |
- sum_weights <- checkmate::assert_int(sum(weights))+ FUN = function(row) {
|
|
| 315 | +916 | ! |
- if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
+ tmp <- vapply( |
| 316 | -+ | ||
| 917 | +! |
-
+ gregexpr("\n", row, fixed = TRUE),
|
|
| 317 | -+ | ||
| 918 | +! |
-
+ attr, numeric(1), |
|
| 318 | -20x | +||
| 919 | +! |
- xs <- tbl["TRUE", ]+ "match.length" |
|
| 319 | -20x | +||
| 920 | +! |
- ns <- colSums(tbl)+ ) + 1 |
|
| 320 | -20x | +||
| 921 | +! |
- use_stratum <- (ns > 0)+ max(c(tmp, 1)) |
|
| 321 | -20x | +||
| 922 | +
- ns <- ns[use_stratum]+ } |
||
| 322 | -20x | +||
| 923 | +
- xs <- xs[use_stratum]+ ) |
||
| 323 | -20x | +||
| 924 | +
- ests <- xs / ns+ |
||
| 324 | -20x | +||
| 925 | +! |
- vars <- ests * (1 - ests) / ns+ i_header <- seq_len(nr_h) |
|
| 325 | +926 | ||
| 326 | -20x | +||
| 927 | +! |
- strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)+ height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines") |
|
| 327 | -+ | ||
| 928 | +! |
-
+ height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines") |
|
| 328 | +929 |
- # Iterative setting of weights if they were not set externally+ |
|
| 329 | -20x | +||
| 930 | +! |
- weights_new <- if (do_iter) {
+ height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines") |
|
| 330 | -6x | +||
| 931 | +! |
- update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights+ height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines") |
|
| 331 | +932 |
- } else {
+
|
|
| 332 | -14x | +||
| 933 | +! |
- weights+ nc_g <- nc + 2 # number of columns incl. row names and forest |
|
| 333 | +934 |
- }+ |
|
| 334 | -+ | ||
| 935 | +! |
-
+ vp_tbl <- grid::vpTree( |
|
| 335 | -20x | +||
| 936 | +! |
- strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1+ parent = grid::viewport( |
|
| 336 | -+ | ||
| 937 | +! |
-
+ name = "vp_table_layout", |
|
| 337 | -20x | +||
| 938 | +! |
- ci_by_strata <- Map(+ layout = grid::grid.layout( |
|
| 338 | -20x | +||
| 939 | +! |
- function(x, n) {
+ nrow = 3, ncol = 1, |
|
| 339 | -+ | ||
| 940 | +! |
- # Classic Wilson's confidence interval+ heights = grid::unit.c(height_header, gap_header, height_body) |
|
| 340 | -139x | +||
| 941 | +
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)+ ) |
||
| 341 | +942 |
- },+ ), |
|
| 342 | -20x | +||
| 943 | +! |
- x = xs,+ children = grid::vpList( |
|
| 343 | -20x | +||
| 944 | +! |
- n = ns+ vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),+ |
+ |
| 945 | +! | +
+ vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),+ |
+ |
| 946 | +! | +
+ grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1) |
|
| 344 | +947 |
- )+ ) |
|
| 345 | -20x | +||
| 948 | +
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ ) |
||
| 346 | -20x | +||
| 949 | +! |
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ vp_tbl |
|
| 347 | +950 |
-
+ } |
|
| 348 | -20x | +||
| 951 | +
- lower <- sum(weights_new * lower_by_strata)+ |
||
| 349 | -20x | +||
| 952 | +
- upper <- sum(weights_new * upper_by_strata)+ #' Viewport Forest Plot: Table Part |
||
| 350 | +953 |
-
+ #' |
|
| 351 | +954 |
- # Return values+ #' Prepares a viewport for the table included in the forest plot. |
|
| 352 | -20x | +||
| 955 | +
- if (do_iter) {
+ #' |
||
| 353 | -6x | +||
| 956 | +
- list(+ #' @noRd |
||
| 354 | -6x | +||
| 957 | +
- conf_int = c(+ vp_forest_table_part <- function(nrow, |
||
| 355 | -6x | +||
| 958 | +
- lower = lower,+ ncol, |
||
| 356 | -6x | +||
| 959 | +
- upper = upper+ l_row, |
||
| 357 | +960 |
- ),+ l_col, |
|
| 358 | -6x | +||
| 961 | +
- weights = weights_new+ widths, |
||
| 359 | +962 |
- )+ heights, |
|
| 360 | +963 |
- } else {
+ name) {
|
|
| 361 | -14x | +||
| 964 | +! |
- list(+ grid::vpTree( |
|
| 362 | -14x | +||
| 965 | +! |
- conf_int = c(+ grid::viewport( |
|
| 363 | -14x | +||
| 966 | +! |
- lower = lower,+ name = name, |
|
| 364 | -14x | +||
| 967 | +! |
- upper = upper+ layout.pos.row = l_row, |
|
| 365 | -+ | ||
| 968 | +! |
- )+ layout.pos.col = l_col, |
|
| 366 | -+ | ||
| 969 | +! |
- )+ layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights) |
|
| 367 | +970 |
- }+ ), |
|
| 368 | -+ | ||
| 971 | +! |
- }+ children = grid::vpList( |
|
| 369 | -+ | ||
| 972 | +! |
-
+ do.call( |
|
| 370 | -+ | ||
| 973 | +! |
- #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ grid::vpList, |
|
| 371 | -+ | ||
| 974 | +! |
- #' Also referred to as the `exact` method.+ lapply( |
|
| 372 | -+ | ||
| 975 | +! |
- #'+ seq_len(nrow), function(i) {
|
|
| 373 | -+ | ||
| 976 | +! |
- #' @examples+ grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
|
|
| 374 | +977 |
- #' prop_clopper_pearson(rsp, conf_level = .95)+ } |
|
| 375 | +978 |
- #'+ ) |
|
| 376 | +979 |
- #' @export+ ), |
|
| 377 | -+ | ||
| 980 | +! |
- prop_clopper_pearson <- function(rsp,+ do.call( |
|
| 378 | -+ | ||
| 981 | +! |
- conf_level) {
+ grid::vpList, |
|
| 379 | -1x | +||
| 982 | +! |
- y <- stats::binom.test(+ apply( |
|
| 380 | -1x | +||
| 983 | +! |
- x = sum(rsp),+ expand.grid(seq_len(nrow), seq_len(ncol - 2)), |
|
| 381 | -1x | +||
| 984 | +! |
- n = length(rsp),+ 1, |
|
| 382 | -1x | +||
| 985 | +! |
- conf.level = conf_level+ function(x) {
|
|
| 383 | -+ | ||
| 986 | +! |
- )+ i <- x[1] |
|
| 384 | -1x | +||
| 987 | +! |
- as.numeric(y$conf.int)+ j <- x[2] |
|
| 385 | -+ | ||
| 988 | +! |
- }+ grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
|
|
| 386 | +989 |
-
+ } |
|
| 387 | +990 |
- #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition+ ) |
|
| 388 | +991 |
- #' for a single proportion confidence interval using the normal approximation.+ ), |
|
| 389 | -+ | ||
| 992 | +! |
- #'+ do.call( |
|
| 390 | -+ | ||
| 993 | +! |
- #' @param correct (`flag`)\cr apply continuity correction.+ grid::vpList, |
|
| 391 | -+ | ||
| 994 | +! |
- #'+ lapply( |
|
| 392 | -+ | ||
| 995 | +! |
- #' @examples+ seq_len(nrow), |
|
| 393 | -+ | ||
| 996 | +! |
- #' prop_wald(rsp, conf_level = 0.95)+ function(i) {
|
|
| 394 | -+ | ||
| 997 | +! |
- #' prop_wald(rsp, conf_level = 0.95, correct = TRUE)+ grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
|
|
| 395 | +998 |
- #'+ } |
|
| 396 | +999 |
- #' @export+ ) |
|
| 397 | +1000 |
- prop_wald <- function(rsp, conf_level, correct = FALSE) {
+ ) |
|
| 398 | -132x | +||
| 1001 | +
- n <- length(rsp)+ ) |
||
| 399 | -132x | +||
| 1002 | +
- p_hat <- mean(rsp)+ ) |
||
| 400 | -132x | +||
| 1003 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ } |
||
| 401 | -132x | +||
| 1004 | +
- q_hat <- 1 - p_hat+ |
||
| 402 | -132x | +||
| 1005 | +
- correct <- if (correct) 1 / (2 * n) else 0+ #' Forest Rendering |
||
| 403 | +1006 |
-
+ #' |
|
| 404 | -132x | +||
| 1007 | +
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct+ #' Renders the forest grob. |
||
| 405 | -132x | +||
| 1008 | +
- l_ci <- max(0, p_hat - err)+ #' |
||
| 406 | -132x | +||
| 1009 | +
- u_ci <- min(1, p_hat + err)+ #' @noRd |
||
| 407 | +1010 |
-
+ grid.forest <- function(...) { # nolint
|
|
| 408 | -132x | +||
| 1011 | +! |
- c(l_ci, u_ci)+ grid::grid.draw(forest_grob(...)) |
|
| 409 | +1012 |
} |
| 410 | +1 |
-
+ #' Estimation of Proportions |
||
| 411 | +2 |
- #' @describeIn h_proportions Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by+ #' |
||
| 412 | +3 |
- #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI.+ #' @description `r lifecycle::badge("stable")`
|
||
| 413 | +4 |
#' |
||
| 414 | +5 |
- #' @examples+ #' Estimate the proportion of responders within a studied population. |
||
| 415 | +6 |
- #' prop_agresti_coull(rsp, conf_level = 0.95)+ #' |
||
| 416 | +7 |
- #'+ #' @inheritParams prop_strat_wilson |
||
| 417 | +8 |
- #' @export+ #' @inheritParams argument_convention |
||
| 418 | +9 |
- prop_agresti_coull <- function(rsp, conf_level) {
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion")`
|
||
| 419 | -2x | +|||
| 10 | +
- n <- length(rsp)+ #' to see available statistics for this function. |
|||
| 420 | -2x | +|||
| 11 | +
- x_sum <- sum(rsp)+ #' @param method (`string`)\cr the method used to construct the confidence interval |
|||
| 421 | -2x | +|||
| 12 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`, |
|||
| 422 | +13 |
-
+ #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`. |
||
| 423 | +14 |
- # Add here both z^2 / 2 successes and failures.+ #' @param long (`flag`)\cr a long description is required. |
||
| 424 | -2x | +|||
| 15 | +
- x_sum_tilde <- x_sum + z^2 / 2+ #' |
|||
| 425 | -2x | +|||
| 16 | +
- n_tilde <- n + z^2+ #' @seealso [h_proportions] |
|||
| 426 | +17 |
-
+ #' |
||
| 427 | +18 |
- # Then proceed as with the Wald interval.+ #' @name estimate_proportions |
||
| 428 | -2x | +|||
| 19 | +
- p_tilde <- x_sum_tilde / n_tilde+ #' @order 1 |
|||
| 429 | -2x | +|||
| 20 | +
- q_tilde <- 1 - p_tilde+ NULL |
|||
| 430 | -2x | +|||
| 21 | +
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
|||
| 431 | -2x | +|||
| 22 | +
- l_ci <- max(0, p_tilde - err)+ #' @describeIn estimate_proportions Statistics function estimating a |
|||
| 432 | -2x | +|||
| 23 | +
- u_ci <- min(1, p_tilde + err)+ #' proportion along with its confidence interval. |
|||
| 433 | +24 |
-
+ #' |
||
| 434 | -2x | +|||
| 25 | +
- c(l_ci, u_ci)+ #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used, |
|||
| 435 | +26 |
- }+ #' it indicates whether each subject is a responder or not. `TRUE` represents |
||
| 436 | +27 |
-
+ #' a successful outcome. If a `data.frame` is provided, also the `strata` variable |
||
| 437 | +28 |
- #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the+ #' names must be provided in `variables` as a list element with the strata strings. |
||
| 438 | +29 |
- #' non-informative Jeffreys prior for a binomial proportion.+ #' In the case of `data.frame`, the logical vector of responses must be indicated as a |
||
| 439 | +30 | ++ |
+ #' variable name in `.var`.+ |
+ |
| 31 |
#' |
|||
| 440 | +32 |
- #' @examples+ #' @return |
||
| 441 | +33 |
- #' prop_jeffreys(rsp, conf_level = 0.95)+ #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a |
||
| 442 | +34 |
- #'+ #' given variable. |
||
| 443 | +35 |
- #' @export+ #' |
||
| 444 | +36 |
- prop_jeffreys <- function(rsp,+ #' @examples |
||
| 445 | +37 |
- conf_level) {
+ #' # Case with only logical vector. |
||
| 446 | -4x | +|||
| 38 | +
- n <- length(rsp)+ #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0) |
|||
| 447 | -4x | +|||
| 39 | +
- x_sum <- sum(rsp)+ #' s_proportion(rsp_v) |
|||
| 448 | +40 |
-
+ #' |
||
| 449 | -4x | +|||
| 41 | +
- alpha <- 1 - conf_level+ #' # Example for Stratified Wilson CI |
|||
| 450 | -4x | +|||
| 42 | +
- l_ci <- ifelse(+ #' nex <- 100 # Number of example rows |
|||
| 451 | -4x | +|||
| 43 | +
- x_sum == 0,+ #' dta <- data.frame( |
|||
| 452 | -4x | +|||
| 44 | +
- 0,+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
|||
| 453 | -4x | +|||
| 45 | +
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
|||
| 454 | +46 |
- )+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 455 | +47 |
-
+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
||
| 456 | -4x | +|||
| 48 | +
- u_ci <- ifelse(+ #' stringsAsFactors = TRUE |
|||
| 457 | -4x | +|||
| 49 | +
- x_sum == n,+ #' ) |
|||
| 458 | -4x | +|||
| 50 | +
- 1,+ #' |
|||
| 459 | -4x | +|||
| 51 | +
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ #' s_proportion( |
|||
| 460 | +52 |
- )+ #' df = dta, |
||
| 461 | +53 |
-
+ #' .var = "rsp", |
||
| 462 | -4x | +|||
| 54 | +
- c(l_ci, u_ci)+ #' variables = list(strata = c("f1", "f2")),
|
|||
| 463 | +55 |
- }+ #' conf_level = 0.90, |
||
| 464 | +56 |
-
+ #' method = "strat_wilson" |
||
| 465 | +57 |
- #' Description of the Proportion Summary+ #' ) |
||
| 466 | +58 |
#' |
||
| 467 | +59 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 468 | +60 |
- #'+ s_proportion <- function(df, |
||
| 469 | +61 |
- #' This is a helper function that describes the analysis in [s_proportion()].+ .var, |
||
| 470 | +62 |
- #'+ conf_level = 0.95, |
||
| 471 | +63 |
- #' @inheritParams s_proportion+ method = c( |
||
| 472 | +64 |
- #' @param long (`flag`)\cr whether a long or a short (default) description is required.+ "waldcc", "wald", "clopper-pearson", |
||
| 473 | +65 |
- #'+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
||
| 474 | +66 |
- #' @return String describing the analysis.+ "agresti-coull", "jeffreys" |
||
| 475 | +67 |
- #'+ ), |
||
| 476 | +68 |
- #' @export+ weights = NULL, |
||
| 477 | +69 |
- d_proportion <- function(conf_level,+ max_iterations = 50, |
||
| 478 | +70 |
- method,+ variables = list(strata = NULL), |
||
| 479 | +71 |
long = FALSE) {
|
||
| 480 | -147x | +72 | +135x |
- label <- paste0(conf_level * 100, "% CI")+ method <- match.arg(method) |
| 481 | -+ | |||
| 73 | +135x |
-
+ checkmate::assert_flag(long) |
||
| 482 | -! | +|||
| 74 | +135x |
- if (long) label <- paste(label, "for Response Rates")+ assert_proportion_value(conf_level) |
||
| 483 | +75 | |||
| 484 | -147x | +76 | +135x |
- method_part <- switch(method,+ if (!is.null(variables$strata)) {
|
| 485 | -147x | +|||
| 77 | +
- "clopper-pearson" = "Clopper-Pearson",+ # Checks for strata |
|||
| 486 | -147x | +|||
| 78 | +! |
- "waldcc" = "Wald, with correction",+ if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
|
||
| 487 | -147x | +|||
| 79 | +! |
- "wald" = "Wald, without correction",+ strata_colnames <- variables$strata |
||
| 488 | -147x | +|||
| 80 | +! |
- "wilson" = "Wilson, without correction",+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
||
| 489 | -147x | +|||
| 81 | +! |
- "strat_wilson" = "Stratified Wilson, without correction",+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
||
| 490 | -147x | +|||
| 82 | +! |
- "wilsonc" = "Wilson, with correction",+ assert_df_with_variables(df, strata_vars) |
||
| 491 | -147x | +|||
| 83 | +
- "strat_wilsonc" = "Stratified Wilson, with correction",+ |
|||
| 492 | -147x | +|||
| 84 | +! |
- "agresti-coull" = "Agresti-Coull",+ strata <- interaction(df[strata_colnames]) |
||
| 493 | -147x | +|||
| 85 | +! |
- "jeffreys" = "Jeffreys",+ strata <- as.factor(strata) |
||
| 494 | -147x | +|||
| 86 | +
- stop(paste(method, "does not have a description"))+ |
|||
| 495 | +87 |
- )+ # Pushing down checks to prop_strat_wilson+ |
+ ||
| 88 | +135x | +
+ } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
+ |
+ ||
| 89 | +! | +
+ stop("To use stratified methods you need to specify the strata variables.")
|
||
| 496 | +90 |
-
+ } |
||
| 497 | -147x | +91 | +135x |
- paste0(label, " (", method_part, ")")
+ if (checkmate::test_atomic_vector(df)) {
|
| 498 | -+ | |||
| 92 | +135x |
- }+ rsp <- as.logical(df) |
||
| 499 | +93 |
-
+ } else {
|
||
| 500 | -+ | |||
| 94 | +! |
- #' Helper Function for the Estimation of Stratified Quantiles+ rsp <- as.logical(df[[.var]]) |
||
| 501 | +95 |
- #'+ } |
||
| 502 | -+ | |||
| 96 | +135x |
- #' @description `r lifecycle::badge("stable")`
+ n <- sum(rsp) |
||
| 503 | -+ | |||
| 97 | +135x |
- #'+ p_hat <- mean(rsp) |
||
| 504 | +98 |
- #' This function wraps the estimation of stratified percentiles when we assume+ |
||
| 505 | -+ | |||
| 99 | +135x |
- #' the approximation for large numbers. This is necessary only in the case+ prop_ci <- switch(method, |
||
| 506 | -+ | |||
| 100 | +135x |
- #' proportions for each strata are unequal.+ "clopper-pearson" = prop_clopper_pearson(rsp, conf_level), |
||
| 507 | -+ | |||
| 101 | +135x |
- #'+ "wilson" = prop_wilson(rsp, conf_level), |
||
| 508 | -+ | |||
| 102 | +135x |
- #' @inheritParams argument_convention+ "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE), |
||
| 509 | -+ | |||
| 103 | +135x |
- #' @inheritParams prop_strat_wilson+ "strat_wilson" = prop_strat_wilson(rsp, |
||
| 510 | -+ | |||
| 104 | +135x |
- #'+ strata, |
||
| 511 | -+ | |||
| 105 | +135x |
- #' @return Stratified quantile.+ weights, |
||
| 512 | -+ | |||
| 106 | +135x |
- #'+ conf_level, |
||
| 513 | -+ | |||
| 107 | +135x |
- #' @seealso [prop_strat_wilson()]+ max_iterations,+ |
+ ||
| 108 | +135x | +
+ correct = FALSE+ |
+ ||
| 109 | +135x | +
+ )$conf_int,+ |
+ ||
| 110 | +135x | +
+ "strat_wilsonc" = prop_strat_wilson(rsp,+ |
+ ||
| 111 | +135x | +
+ strata,+ |
+ ||
| 112 | +135x | +
+ weights,+ |
+ ||
| 113 | +135x | +
+ conf_level,+ |
+ ||
| 114 | +135x | +
+ max_iterations,+ |
+ ||
| 115 | +135x | +
+ correct = TRUE+ |
+ ||
| 116 | +135x | +
+ )$conf_int,+ |
+ ||
| 117 | +135x | +
+ "wald" = prop_wald(rsp, conf_level),+ |
+ ||
| 118 | +135x | +
+ "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),+ |
+ ||
| 119 | +135x | +
+ "agresti-coull" = prop_agresti_coull(rsp, conf_level),+ |
+ ||
| 120 | +135x | +
+ "jeffreys" = prop_jeffreys(rsp, conf_level) |
||
| 514 | +121 |
- #'+ ) |
||
| 515 | +122 |
- #' @examples+ + |
+ ||
| 123 | +135x | +
+ list(+ |
+ ||
| 124 | +135x | +
+ "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),+ |
+ ||
| 125 | +135x | +
+ "prop_ci" = formatters::with_label(+ |
+ ||
| 126 | +135x | +
+ x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long) |
||
| 516 | +127 |
- #' strata_data <- table(data.frame(+ ) |
||
| 517 | +128 |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ ) |
||
| 518 | +129 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ } |
||
| 519 | +130 |
- #' stringsAsFactors = TRUE+ |
||
| 520 | +131 |
- #' ))+ #' @describeIn estimate_proportions Formatted analysis function which is used as `afun` |
||
| 521 | +132 |
- #' ns <- colSums(strata_data)+ #' in `estimate_proportion()`. |
||
| 522 | +133 |
- #' ests <- strata_data["TRUE", ] / ns+ #' |
||
| 523 | +134 |
- #' vars <- ests * (1 - ests) / ns+ #' @return |
||
| 524 | +135 |
- #' weights <- rep(1 / length(ns), length(ns))+ #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 525 | +136 |
#' |
||
| 526 | +137 |
- #' strata_normal_quantile(vars, weights, 0.95)+ #' @export |
||
| 527 | +138 |
- #'+ a_proportion <- make_afun( |
||
| 528 | +139 |
- #' @export+ s_proportion, |
||
| 529 | +140 |
- strata_normal_quantile <- function(vars, weights, conf_level) {
+ .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)") |
||
| 530 | -41x | +|||
| 141 | +
- summands <- weights^2 * vars+ ) |
|||
| 531 | +142 |
- # Stratified quantile+ |
||
| 532 | -41x | +|||
| 143 | +
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)+ #' @describeIn estimate_proportions Layout-creating function which can take statistics function arguments |
|||
| 533 | +144 |
- }+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 534 | +145 |
-
+ #' |
||
| 535 | +146 |
- #' Helper Function for the Estimation of Weights for `prop_strat_wilson`+ #' @return |
||
| 536 | +147 |
- #'+ #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions, |
||
| 537 | +148 |
- #' @description `r lifecycle::badge("stable")`
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 538 | +149 |
- #'+ #' the statistics from `s_proportion()` to the table layout. |
||
| 539 | +150 |
- #' This function wraps the iteration procedure that allows you to estimate+ #' |
||
| 540 | +151 |
- #' the weights for each proportional strata. This assumes to minimize the+ #' @examples |
||
| 541 | +152 |
- #' weighted squared length of the confidence interval.+ #' dta_test <- data.frame( |
||
| 542 | +153 |
- #'+ #' USUBJID = paste0("S", 1:12),
|
||
| 543 | +154 |
- #' @inheritParams prop_strat_wilson+ #' ARM = rep(LETTERS[1:3], each = 4), |
||
| 544 | +155 |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0)) |
||
| 545 | +156 |
- #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ #' ) |
||
| 546 | +157 |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ #' |
||
| 547 | +158 |
- #' be optimized in the future if we need to estimate better initial weights.+ #' basic_table() %>% |
||
| 548 | +159 |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ #' split_cols_by("ARM") %>%
|
||
| 549 | +160 |
- #' @param max_iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ #' estimate_proportion(vars = "AVAL") %>% |
||
| 550 | +161 |
- #' @param tol (`number`)\cr tolerance threshold for convergence.+ #' build_table(df = dta_test) |
||
| 551 | +162 |
#' |
||
| 552 | +163 |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ #' @export |
||
| 553 | +164 |
- #'+ #' @order 2 |
||
| 554 | +165 |
- #' @seealso For references and details see [prop_strat_wilson()].+ estimate_proportion <- function(lyt, |
||
| 555 | +166 |
- #'+ vars, |
||
| 556 | +167 |
- #' @examples+ conf_level = 0.95, |
||
| 557 | +168 |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ method = c( |
||
| 558 | +169 |
- #' sq <- 0.674+ "waldcc", "wald", "clopper-pearson", |
||
| 559 | +170 |
- #' ws <- rep(1 / length(vs), length(vs))+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
||
| 560 | +171 |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ "agresti-coull", "jeffreys" |
||
| 561 | +172 |
- #'+ ), |
||
| 562 | +173 |
- #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ weights = NULL, |
||
| 563 | +174 |
- #'+ max_iterations = 50, |
||
| 564 | +175 |
- #' @export+ variables = list(strata = NULL), |
||
| 565 | +176 |
- update_weights_strat_wilson <- function(vars,+ long = FALSE, |
||
| 566 | +177 |
- strata_qnorm,+ na_str = default_na_str(), |
||
| 567 | +178 |
- initial_weights,+ nested = TRUE, |
||
| 568 | +179 |
- n_per_strata,+ ..., |
||
| 569 | +180 |
- max_iterations = 50,+ show_labels = "hidden", |
||
| 570 | +181 |
- conf_level = 0.95,+ table_names = vars, |
||
| 571 | +182 |
- tol = 0.001) {
+ .stats = NULL, |
||
| 572 | -8x | +|||
| 183 | +
- it <- 0+ .formats = NULL, |
|||
| 573 | -8x | +|||
| 184 | +
- diff_v <- NULL+ .labels = NULL, |
|||
| 574 | +185 |
-
+ .indent_mods = NULL) {
|
||
| 575 | -8x | +186 | +3x |
- while (it < max_iterations) {
+ extra_args <- list( |
| 576 | -19x | +187 | +3x |
- it <- it + 1+ conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations, |
| 577 | -19x | +188 | +3x |
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ variables = variables, long = long, ... |
| 578 | -19x | +|||
| 189 | +
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ )+ |
+ |||
| 190 | ++ | + | ||
| 579 | -19x | +191 | +3x |
- weights_new <- weights_new_t / weights_new_b+ afun <- make_afun( |
| 580 | -19x | +192 | +3x |
- weights_new <- weights_new / sum(weights_new)+ a_proportion, |
| 581 | -19x | +193 | +3x |
- strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)+ .stats = .stats, |
| 582 | -19x | +194 | +3x |
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ .formats = .formats, |
| 583 | -8x | +195 | +3x |
- if (diff_v[length(diff_v)] < tol) break+ .labels = .labels, |
| 584 | -11x | +196 | +3x |
- initial_weights <- weights_new+ .indent_mods = .indent_mods |
| 585 | +197 |
- }+ ) |
||
| 586 | -+ | |||
| 198 | +3x |
-
+ analyze( |
||
| 587 | -8x | +199 | +3x |
- if (it == max_iterations) {
+ lyt, |
| 588 | -! | +|||
| 200 | +3x |
- warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
+ vars, |
||
| 589 | -+ | |||
| 201 | +3x |
- }+ afun = afun, |
||
| 590 | -+ | |||
| 202 | +3x |
-
+ na_str = na_str, |
||
| 591 | -8x | +203 | +3x |
- list(+ nested = nested, |
| 592 | -8x | +204 | +3x |
- "n_it" = it,+ extra_args = extra_args, |
| 593 | -8x | +205 | +3x |
- "weights" = weights_new,+ show_labels = show_labels, |
| 594 | -8x | +206 | +3x |
- "diff_v" = diff_v+ table_names = table_names |
| 595 | +207 |
) |
||
| 596 | +208 |
} |
| 1 | +209 |
- #' Tabulate Binary Response by Subgroup+ |
||
| 2 | +210 | ++ |
+ #' Helper Functions for Calculating Proportion Confidence Intervals+ |
+ |
| 211 |
#' |
|||
| 3 | +212 |
#' @description `r lifecycle::badge("stable")`
|
||
| 4 | +213 |
#' |
||
| 5 | +214 |
- #' Tabulate statistics such as response rate and odds ratio for population subgroups.+ #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()]. |
||
| 6 | +215 |
#' |
||
| 7 | +216 |
- #' @inheritParams extract_rsp_subgroups+ #' @inheritParams argument_convention |
||
| 8 | +217 |
- #' @inheritParams argument_convention+ #' @inheritParams estimate_proportions |
||
| 9 | +218 |
#' |
||
| 10 | +219 |
- #' @details These functions create a layout starting from a data frame which contains+ #' @return Confidence interval of a proportion. |
||
| 11 | +220 |
- #' the required statistics. Tables typically used as part of forest plot.+ #' |
||
| 12 | +221 |
- #'+ #' @seealso [estimate_proportions], descriptive function [d_proportion()], |
||
| 13 | +222 |
- #' @seealso [extract_rsp_subgroups()]+ #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()]. |
||
| 14 | +223 |
#' |
||
| 15 | +224 |
- #' @examples+ #' @name h_proportions |
||
| 16 | +225 |
- #' library(dplyr)+ NULL |
||
| 17 | +226 |
- #' library(forcats)+ |
||
| 18 | +227 |
- #'+ #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()]. |
||
| 19 | +228 |
- #' adrs <- tern_ex_adrs+ #' Also referred to as Wilson score interval. |
||
| 20 | +229 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' |
||
| 21 | +230 |
- #'+ #' @examples |
||
| 22 | +231 |
- #' adrs_f <- adrs %>%+ #' rsp <- c( |
||
| 23 | +232 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' TRUE, TRUE, TRUE, TRUE, TRUE, |
||
| 24 | +233 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ #' FALSE, FALSE, FALSE, FALSE, FALSE |
||
| 25 | +234 |
- #' droplevels() %>%+ #' ) |
||
| 26 | +235 |
- #' mutate(+ #' prop_wilson(rsp, conf_level = 0.9) |
||
| 27 | +236 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ #' |
||
| 28 | +237 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ #' @export |
||
| 29 | +238 |
- #' rsp = AVALC == "CR"+ prop_wilson <- function(rsp, conf_level, correct = FALSE) {
|
||
| 30 | -+ | |||
| 239 | +5x |
- #' )+ y <- stats::prop.test( |
||
| 31 | -+ | |||
| 240 | +5x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ sum(rsp), |
||
| 32 | -+ | |||
| 241 | +5x |
- #'+ length(rsp), |
||
| 33 | -+ | |||
| 242 | +5x |
- #' # Unstratified analysis.+ correct = correct, |
||
| 34 | -+ | |||
| 243 | +5x |
- #' df <- extract_rsp_subgroups(+ conf.level = conf_level |
||
| 35 | +244 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ ) |
||
| 36 | +245 |
- #' data = adrs_f+ + |
+ ||
| 246 | +5x | +
+ as.numeric(y$conf.int) |
||
| 37 | +247 |
- #' )+ } |
||
| 38 | +248 |
- #' df+ |
||
| 39 | +249 |
- #'+ #' @describeIn h_proportions Calculates the stratified Wilson confidence |
||
| 40 | +250 |
- #' # Stratified analysis.+ #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
|
||
| 41 | +251 |
- #' df_strat <- extract_rsp_subgroups(+ #' |
||
| 42 | +252 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strat = "STRATA1"),
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 43 | +253 |
- #' data = adrs_f+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are |
||
| 44 | +254 |
- #' )+ #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
|
||
| 45 | +255 |
- #' df_strat+ #' minimizes the weighted squared length of the confidence interval. |
||
| 46 | +256 |
- #'+ #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used |
||
| 47 | +257 |
- #' # Grouping of the BMRKR2 levels.+ #' to find estimates of optimal weights. |
||
| 48 | +258 |
- #' df_grouped <- extract_rsp_subgroups(+ #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example |
||
| 49 | +259 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' [stats::prop.test()]. |
||
| 50 | +260 |
- #' data = adrs_f,+ #' |
||
| 51 | +261 |
- #' groups_lists = list(+ #' @references |
||
| 52 | +262 |
- #' BMRKR2 = list(+ #' \insertRef{Yan2010-jt}{tern}
|
||
| 53 | +263 |
- #' "low" = "LOW",+ #' |
||
| 54 | +264 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' @examples |
||
| 55 | +265 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' # Stratified Wilson confidence interval with unequal probabilities |
||
| 56 | +266 |
- #' )+ #' |
||
| 57 | +267 |
- #' )+ #' set.seed(1) |
||
| 58 | +268 |
- #' )+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
||
| 59 | +269 |
- #' df_grouped+ #' strata_data <- data.frame( |
||
| 60 | +270 |
- #'+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 61 | +271 |
- #' @name response_subgroups+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 62 | +272 |
- #' @order 1+ #' stringsAsFactors = TRUE |
||
| 63 | +273 |
- NULL+ #' ) |
||
| 64 | +274 |
-
+ #' strata <- interaction(strata_data) |
||
| 65 | +275 |
- #' Prepares Response Data for Population Subgroups in Data Frames+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata |
||
| 66 | +276 |
#' |
||
| 67 | +277 |
- #' @description `r lifecycle::badge("stable")`
+ #' prop_strat_wilson( |
||
| 68 | +278 |
- #'+ #' rsp = rsp, strata = strata, |
||
| 69 | +279 |
- #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper+ #' conf_level = 0.90 |
||
| 70 | +280 |
- #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two+ #' ) |
||
| 71 | +281 |
- #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`,+ #' |
||
| 72 | +282 |
- #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strat`.+ #' # Not automatic setting of weights |
||
| 73 | +283 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' prop_strat_wilson( |
||
| 74 | +284 |
- #'+ #' rsp = rsp, strata = strata, |
||
| 75 | +285 |
- #' @inheritParams argument_convention+ #' weights = rep(1 / n_strata, n_strata), |
||
| 76 | +286 |
- #' @inheritParams response_subgroups+ #' conf_level = 0.90 |
||
| 77 | +287 |
- #' @param label_all (`string`)\cr label for the total population analysis.+ #' ) |
||
| 78 | +288 |
#' |
||
| 79 | +289 |
- #' @return A named list of two elements:+ #' @export |
||
| 80 | +290 |
- #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`,+ prop_strat_wilson <- function(rsp, |
||
| 81 | +291 |
- #' `var_label`, and `row_type`.+ strata, |
||
| 82 | +292 |
- #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`,+ weights = NULL, |
||
| 83 | +293 |
- #' `subgroup`, `var`, `var_label`, and `row_type`.+ conf_level = 0.95, |
||
| 84 | +294 |
- #'+ max_iterations = NULL, |
||
| 85 | +295 |
- #' @seealso [response_subgroups]+ correct = FALSE) {
|
||
| 86 | -+ | |||
| 296 | +20x |
- #'+ checkmate::assert_logical(rsp, any.missing = FALSE) |
||
| 87 | -+ | |||
| 297 | +20x |
- #' @export+ checkmate::assert_factor(strata, len = length(rsp)) |
||
| 88 | -+ | |||
| 298 | +20x |
- extract_rsp_subgroups <- function(variables,+ assert_proportion_value(conf_level) |
||
| 89 | +299 |
- data,+ |
||
| 90 | -+ | |||
| 300 | +20x |
- groups_lists = list(),+ tbl <- table(rsp, strata) |
||
| 91 | -+ | |||
| 301 | +20x |
- conf_level = 0.95,+ n_strata <- length(unique(strata)) |
||
| 92 | +302 |
- method = NULL,+ |
||
| 93 | +303 |
- label_all = "All Patients") {
- |
- ||
| 94 | -11x | -
- df_prop <- h_proportion_subgroups_df(+ # Checking the weights and maximum number of iterations. |
||
| 95 | -11x | +304 | +20x |
- variables,+ do_iter <- FALSE |
| 96 | -11x | +305 | +20x |
- data,+ if (is.null(weights)) {
|
| 97 | -11x | +306 | +6x |
- groups_lists = groups_lists,+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
| 98 | -11x | +307 | +6x |
- label_all = label_all+ do_iter <- TRUE |
| 99 | +308 |
- )+ |
||
| 100 | -11x | +|||
| 309 | +
- df_or <- h_odds_ratio_subgroups_df(+ # Iteration parameters |
|||
| 101 | -11x | +310 | +2x |
- variables,+ if (is.null(max_iterations)) max_iterations <- 10 |
| 102 | -11x | +311 | +6x |
- data,+ checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1) |
| 103 | -11x | +|||
| 312 | +
- groups_lists = groups_lists,+ } |
|||
| 104 | -11x | +313 | +20x |
- conf_level = conf_level,+ checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata) |
| 105 | -11x | +314 | +20x |
- method = method,+ sum_weights <- checkmate::assert_int(sum(weights)) |
| 106 | -11x | +|||
| 315 | +! |
- label_all = label_all+ if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
|
||
| 107 | +316 |
- )+ |
||
| 108 | +317 | |||
| 109 | -11x | +318 | +20x |
- list(prop = df_prop, or = df_or)+ xs <- tbl["TRUE", ] |
| 110 | -+ | |||
| 319 | +20x |
- }+ ns <- colSums(tbl) |
||
| 111 | -+ | |||
| 320 | +20x |
-
+ use_stratum <- (ns > 0) |
||
| 112 | -+ | |||
| 321 | +20x |
- #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`.+ ns <- ns[use_stratum] |
||
| 113 | -+ | |||
| 322 | +20x |
- #'+ xs <- xs[use_stratum] |
||
| 114 | -+ | |||
| 323 | +20x |
- #' @return+ ests <- xs / ns |
||
| 115 | -+ | |||
| 324 | +20x |
- #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ vars <- ests * (1 - ests) / ns |
||
| 116 | +325 |
- #'+ |
||
| 117 | -+ | |||
| 326 | +20x |
- #' @keywords internal+ strata_qnorm <- strata_normal_quantile(vars, weights, conf_level) |
||
| 118 | +327 |
- a_response_subgroups <- function(.formats = list(+ |
||
| 119 | +328 |
- n = "xx", # nolint start+ # Iterative setting of weights if they were not set externally |
||
| 120 | -+ | |||
| 329 | +20x |
- n_rsp = "xx",+ weights_new <- if (do_iter) {
|
||
| 121 | -+ | |||
| 330 | +6x |
- prop = "xx.x%",+ update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights |
||
| 122 | +331 |
- n_tot = "xx",+ } else {
|
||
| 123 | -+ | |||
| 332 | +14x |
- or = list(format_extreme_values(2L)),+ weights |
||
| 124 | +333 |
- ci = list(format_extreme_values_ci(2L)),+ } |
||
| 125 | +334 |
- pval = "x.xxxx | (<0.0001)" # nolint end+ |
||
| 126 | -+ | |||
| 335 | +20x |
- ),+ strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1 |
||
| 127 | +336 |
- na_str = default_na_str()) {
+
|
||
| 128 | -17x | +337 | +20x |
- checkmate::assert_list(.formats)+ ci_by_strata <- Map( |
| 129 | -17x | +338 | +20x |
- checkmate::assert_subset(+ function(x, n) {
|
| 130 | -17x | +|||
| 339 | +
- names(.formats),+ # Classic Wilson's confidence interval |
|||
| 131 | -17x | -
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
- |
- ||
| 132 | -+ | 340 | +139x |
- )+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int) |
| 133 | +341 | - - | -||
| 134 | -17x | -
- afun_lst <- Map(+ }, |
||
| 135 | -17x | +342 | +20x |
- function(stat, fmt, na_str) {
+ x = xs, |
| 136 | -114x | +343 | +20x |
- if (stat == "ci") {
+ n = ns |
| 137 | -16x | +|||
| 344 | +
- function(df, labelstr = "", ...) {
+ ) |
|||
| 138 | -36x | +345 | +20x |
- in_rows(+ lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
| 139 | -36x | +346 | +20x |
- .list = combine_vectors(df$lcl, df$ucl),+ upper_by_strata <- sapply(ci_by_strata, "[", 2L) |
| 140 | -36x | +|||
| 347 | +
- .labels = as.character(df$subgroup),+ |
|||
| 141 | -36x | +348 | +20x |
- .formats = fmt,+ lower <- sum(weights_new * lower_by_strata) |
| 142 | -36x | -
- .format_na_strs = na_str- |
- ||
| 143 | -+ | 349 | +20x |
- )+ upper <- sum(weights_new * upper_by_strata) |
| 144 | +350 |
- }+ |
||
| 145 | +351 |
- } else {
+ # Return values |
||
| 146 | -98x | +352 | +20x |
- function(df, labelstr = "", ...) {
+ if (do_iter) {
|
| 147 | -211x | +353 | +6x |
- in_rows(+ list( |
| 148 | -211x | +354 | +6x |
- .list = as.list(df[[stat]]),+ conf_int = c( |
| 149 | -211x | +355 | +6x |
- .labels = as.character(df$subgroup),+ lower = lower, |
| 150 | -211x | +356 | +6x |
- .formats = fmt,+ upper = upper |
| 151 | -211x | +|||
| 357 | +
- .format_na_strs = na_str+ ), |
|||
| 152 | -+ | |||
| 358 | +6x |
- )+ weights = weights_new |
||
| 153 | +359 |
- }+ ) |
||
| 154 | +360 |
- }+ } else {
|
||
| 155 | -+ | |||
| 361 | +14x |
- },+ list( |
||
| 156 | -17x | +362 | +14x |
- stat = names(.formats),+ conf_int = c( |
| 157 | -17x | +363 | +14x |
- fmt = .formats,+ lower = lower, |
| 158 | -17x | +364 | +14x |
- na_str = na_str+ upper = upper |
| 159 | +365 |
- )+ ) |
||
| 160 | +366 |
-
+ ) |
||
| 161 | -17x | +|||
| 367 | +
- afun_lst+ } |
|||
| 162 | +368 |
} |
||
| 163 | +369 | |||
| 164 | +370 |
- #' @describeIn response_subgroups Table-creating function which creates a table+ #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
||
| 165 | +371 |
- #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ #' Also referred to as the `exact` method. |
||
| 166 | +372 |
- #' and [rtables::summarize_row_groups()].+ #' |
||
| 167 | +373 |
- #'+ #' @examples |
||
| 168 | +374 |
- #' @param df (`list`)\cr of data frames containing all analysis variables. List should be+ #' prop_clopper_pearson(rsp, conf_level = .95) |
||
| 169 | +375 |
- #' created using [extract_rsp_subgroups()].+ #' |
||
| 170 | +376 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' @export |
||
| 171 | +377 |
- #' * `n`: Total number of observations per group.+ prop_clopper_pearson <- function(rsp, |
||
| 172 | +378 |
- #' * `n_rsp`: Number of responders per group.+ conf_level) {
|
||
| 173 | -+ | |||
| 379 | +1x |
- #' * `prop`: Proportion of responders.+ y <- stats::binom.test(+ |
+ ||
| 380 | +1x | +
+ x = sum(rsp),+ |
+ ||
| 381 | +1x | +
+ n = length(rsp),+ |
+ ||
| 382 | +1x | +
+ conf.level = conf_level |
||
| 174 | +383 |
- #' * `n_tot`: Total number of observations.+ )+ |
+ ||
| 384 | +1x | +
+ as.numeric(y$conf.int) |
||
| 175 | +385 |
- #' * `or`: Odds ratio.+ } |
||
| 176 | +386 |
- #' * `ci` : Confidence interval of odds ratio.+ |
||
| 177 | +387 |
- #' * `pval`: p-value of the effect.+ #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition |
||
| 178 | +388 |
- #' Note, the statistics `n_tot`, `or` and `ci` are required.+ #' for a single proportion confidence interval using the normal approximation. |
||
| 179 | +389 |
#' |
||
| 180 | +390 |
- #' @return An `rtables` table summarizing binary response by subgroup.+ #' @param correct (`flag`)\cr apply continuity correction. |
||
| 181 | +391 |
#' |
||
| 182 | +392 |
#' @examples |
||
| 183 | +393 |
- #' ## Table with default columns.+ #' prop_wald(rsp, conf_level = 0.95) |
||
| 184 | +394 |
- #' basic_table() %>%+ #' prop_wald(rsp, conf_level = 0.95, correct = TRUE) |
||
| 185 | +395 |
- #' tabulate_rsp_subgroups(df)+ #' |
||
| 186 | +396 |
- #'+ #' @export |
||
| 187 | +397 |
- #' ## Table with selected columns.+ prop_wald <- function(rsp, conf_level, correct = FALSE) {
|
||
| 188 | -+ | |||
| 398 | +132x |
- #' basic_table() %>%+ n <- length(rsp) |
||
| 189 | -+ | |||
| 399 | +132x |
- #' tabulate_rsp_subgroups(+ p_hat <- mean(rsp)+ |
+ ||
| 400 | +132x | +
+ z <- stats::qnorm((1 + conf_level) / 2)+ |
+ ||
| 401 | +132x | +
+ q_hat <- 1 - p_hat+ |
+ ||
| 402 | +132x | +
+ correct <- if (correct) 1 / (2 * n) else 0 |
||
| 190 | +403 |
- #' df = df,+ + |
+ ||
| 404 | +132x | +
+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct+ |
+ ||
| 405 | +132x | +
+ l_ci <- max(0, p_hat - err)+ |
+ ||
| 406 | +132x | +
+ u_ci <- min(1, p_hat + err) |
||
| 191 | +407 |
- #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
+
+ |
+ ||
| 408 | +132x | +
+ c(l_ci, u_ci) |
||
| 192 | +409 |
- #' )+ } |
||
| 193 | +410 |
- #'+ |
||
| 194 | +411 |
- #' @export+ #' @describeIn h_proportions Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by |
||
| 195 | +412 |
- #' @order 2+ #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI. |
||
| 196 | +413 |
- tabulate_rsp_subgroups <- function(lyt,+ #' |
||
| 197 | +414 |
- df,+ #' @examples |
||
| 198 | +415 |
- vars = c("n_tot", "n", "prop", "or", "ci"),
+ #' prop_agresti_coull(rsp, conf_level = 0.95) |
||
| 199 | +416 |
- groups_lists = list(),+ #' |
||
| 200 | +417 |
- label_all = "All Patients",+ #' @export |
||
| 201 | +418 |
- na_str = default_na_str()) {
+ prop_agresti_coull <- function(rsp, conf_level) {
|
||
| 202 | -8x | +419 | +2x |
- conf_level <- df$or$conf_level[1]+ n <- length(rsp) |
| 203 | -8x | +420 | +2x |
- method <- if ("pval_label" %in% names(df$or)) {
+ x_sum <- sum(rsp) |
| 204 | -5x | +421 | +2x |
- df$or$pval_label[1]+ z <- stats::qnorm((1 + conf_level) / 2) |
| 205 | +422 |
- } else {
- |
- ||
| 206 | -3x | -
- NULL+ |
||
| 207 | +423 |
- }+ # Add here both z^2 / 2 successes and failures. |
||
| 208 | -+ | |||
| 424 | +2x |
-
+ x_sum_tilde <- x_sum + z^2 / 2 |
||
| 209 | -8x | +425 | +2x |
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all)+ n_tilde <- n + z^2 |
| 210 | +426 | |||
| 211 | -8x | -
- afun_lst <- a_response_subgroups(na_str = na_str)- |
- ||
| 212 | -8x | -
- colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)- |
- ||
| 213 | +427 |
-
+ # Then proceed as with the Wald interval. |
||
| 214 | -8x | +428 | +2x |
- colvars_prop <- list(+ p_tilde <- x_sum_tilde / n_tilde |
| 215 | -8x | +429 | +2x |
- vars = colvars$vars[names(colvars$labels) %in% c("n", "prop", "n_rsp")],
+ q_tilde <- 1 - p_tilde |
| 216 | -8x | +430 | +2x |
- labels = colvars$labels[names(colvars$labels) %in% c("n", "prop", "n_rsp")]
+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
| 217 | -+ | |||
| 431 | +2x |
- )+ l_ci <- max(0, p_tilde - err) |
||
| 218 | -8x | +432 | +2x |
- colvars_or <- list(+ u_ci <- min(1, p_tilde + err) |
| 219 | -8x | +|||
| 433 | +
- vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")],
+
|
|||
| 220 | -8x | +434 | +2x |
- labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")]
+ c(l_ci, u_ci) |
| 221 | +435 |
- )+ } |
||
| 222 | +436 | |||
| 223 | +437 |
- # Columns from table_prop are optional.+ #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the |
||
| 224 | -8x | +|||
| 438 | +
- if (length(colvars_prop$vars) > 0) {
+ #' non-informative Jeffreys prior for a binomial proportion. |
|||
| 225 | -8x | +|||
| 439 | +
- lyt_prop <- split_cols_by(lyt = lyt, var = "arm")+ #' |
|||
| 226 | -8x | +|||
| 440 | +
- lyt_prop <- split_cols_by_multivar(+ #' @examples |
|||
| 227 | -8x | +|||
| 441 | +
- lyt = lyt_prop,+ #' prop_jeffreys(rsp, conf_level = 0.95) |
|||
| 228 | -8x | +|||
| 442 | +
- vars = colvars_prop$vars,+ #' |
|||
| 229 | -8x | +|||
| 443 | +
- varlabels = colvars_prop$labels+ #' @export |
|||
| 230 | +444 |
- )+ prop_jeffreys <- function(rsp, |
||
| 231 | +445 |
-
+ conf_level) {
|
||
| 232 | -+ | |||
| 446 | +4x |
- # "All Patients" row+ n <- length(rsp) |
||
| 233 | -8x | +447 | +4x |
- lyt_prop <- split_rows_by(+ x_sum <- sum(rsp)+ |
+
| 448 | ++ | + | ||
| 234 | -8x | +449 | +4x |
- lyt = lyt_prop,+ alpha <- 1 - conf_level |
| 235 | -8x | +450 | +4x |
- var = "row_type",+ l_ci <- ifelse( |
| 236 | -8x | +451 | +4x |
- split_fun = keep_split_levels("content"),
+ x_sum == 0, |
| 237 | -8x | +452 | +4x |
- nested = FALSE,+ 0, |
| 238 | -8x | +453 | +4x |
- child_labels = "hidden"+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 239 | +454 |
- )+ ) |
||
| 240 | -8x | +|||
| 455 | +
- lyt_prop <- analyze_colvars(+ |
|||
| 241 | -8x | +456 | +4x |
- lyt = lyt_prop,+ u_ci <- ifelse( |
| 242 | -8x | +457 | +4x |
- afun = afun_lst[names(colvars_prop$labels)],+ x_sum == n, |
| 243 | -8x | +458 | +4x |
- na_str = na_str,+ 1, |
| 244 | -8x | +459 | +4x |
- extra_args = extra_args+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 245 | +460 |
- )+ ) |
||
| 246 | +461 | |||
| 247 | -8x | +462 | +4x |
- if ("analysis" %in% df$prop$row_type) {
+ c(l_ci, u_ci) |
| 248 | -7x | +|||
| 463 | +
- lyt_prop <- split_rows_by(+ } |
|||
| 249 | -7x | +|||
| 464 | +
- lyt = lyt_prop,+ |
|||
| 250 | -7x | +|||
| 465 | +
- var = "row_type",+ #' Description of the Proportion Summary |
|||
| 251 | -7x | +|||
| 466 | +
- split_fun = keep_split_levels("analysis"),
+ #' |
|||
| 252 | -7x | +|||
| 467 | +
- nested = FALSE,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 253 | -7x | +|||
| 468 | +
- child_labels = "hidden"+ #' |
|||
| 254 | +469 |
- )+ #' This is a helper function that describes the analysis in [s_proportion()]. |
||
| 255 | -7x | +|||
| 470 | +
- lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)+ #' |
|||
| 256 | -7x | +|||
| 471 | +
- lyt_prop <- analyze_colvars(+ #' @inheritParams s_proportion |
|||
| 257 | -7x | +|||
| 472 | +
- lyt = lyt_prop,+ #' @param long (`flag`)\cr whether a long or a short (default) description is required. |
|||
| 258 | -7x | +|||
| 473 | +
- afun = afun_lst[names(colvars_prop$labels)],+ #' |
|||
| 259 | -7x | +|||
| 474 | +
- na_str = na_str,+ #' @return String describing the analysis. |
|||
| 260 | -7x | +|||
| 475 | +
- inclNAs = TRUE,+ #' |
|||
| 261 | -7x | +|||
| 476 | +
- extra_args = extra_args+ #' @export |
|||
| 262 | +477 |
- )+ d_proportion <- function(conf_level, |
||
| 263 | +478 |
- }+ method, |
||
| 264 | +479 |
-
+ long = FALSE) {
|
||
| 265 | -8x | +480 | +147x |
- table_prop <- build_table(lyt_prop, df = df$prop)+ label <- paste0(conf_level * 100, "% CI") |
| 266 | +481 |
- } else {
+
|
||
| 267 | +482 | ! |
- table_prop <- NULL- |
- |
| 268 | -- |
- }+ if (long) label <- paste(label, "for Response Rates") |
||
| 269 | +483 | |||
| 270 | -- |
- # Columns "n_tot", "or", "ci" in table_or are required.- |
- ||
| 271 | -8x | +484 | +147x |
- lyt_or <- split_cols_by(lyt = lyt, var = "arm")+ method_part <- switch(method, |
| 272 | -8x | +485 | +147x |
- lyt_or <- split_cols_by_multivar(+ "clopper-pearson" = "Clopper-Pearson", |
| 273 | -8x | +486 | +147x |
- lyt = lyt_or,+ "waldcc" = "Wald, with correction", |
| 274 | -8x | +487 | +147x |
- vars = colvars_or$vars,+ "wald" = "Wald, without correction", |
| 275 | -8x | -
- varlabels = colvars_or$labels- |
- ||
| 276 | -- |
- )- |
- ||
| 277 | -- | - - | -||
| 278 | -+ | 488 | +147x |
- # "All Patients" row+ "wilson" = "Wilson, without correction", |
| 279 | -8x | +489 | +147x |
- lyt_or <- split_rows_by(+ "strat_wilson" = "Stratified Wilson, without correction", |
| 280 | -8x | +490 | +147x |
- lyt = lyt_or,+ "wilsonc" = "Wilson, with correction", |
| 281 | -8x | +491 | +147x |
- var = "row_type",+ "strat_wilsonc" = "Stratified Wilson, with correction", |
| 282 | -8x | +492 | +147x |
- split_fun = keep_split_levels("content"),
+ "agresti-coull" = "Agresti-Coull", |
| 283 | -8x | +493 | +147x |
- nested = FALSE,+ "jeffreys" = "Jeffreys", |
| 284 | -8x | +494 | +147x |
- child_labels = "hidden"+ stop(paste(method, "does not have a description")) |
| 285 | +495 |
) |
||
| 286 | -8x | -
- lyt_or <- analyze_colvars(- |
- ||
| 287 | -8x | -
- lyt = lyt_or,- |
- ||
| 288 | -8x | +|||
| 496 | +
- afun = afun_lst[names(colvars_or$labels)],+ |
|||
| 289 | -8x | +497 | +147x |
- na_str = na_str,+ paste0(label, " (", method_part, ")")
|
| 290 | -8x | +|||
| 498 | +
- extra_args = extra_args+ } |
|||
| 291 | +499 |
- ) %>%+ |
||
| 292 | -8x | +|||
| 500 | +
- append_topleft("Baseline Risk Factors")
+ #' Helper Function for the Estimation of Stratified Quantiles |
|||
| 293 | +501 |
-
+ #' |
||
| 294 | -8x | +|||
| 502 | +
- if ("analysis" %in% df$or$row_type) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 295 | -7x | +|||
| 503 | +
- lyt_or <- split_rows_by(+ #' |
|||
| 296 | -7x | +|||
| 504 | +
- lyt = lyt_or,+ #' This function wraps the estimation of stratified percentiles when we assume |
|||
| 297 | -7x | +|||
| 505 | +
- var = "row_type",+ #' the approximation for large numbers. This is necessary only in the case |
|||
| 298 | -7x | +|||
| 506 | +
- split_fun = keep_split_levels("analysis"),
+ #' proportions for each strata are unequal. |
|||
| 299 | -7x | +|||
| 507 | +
- nested = FALSE,+ #' |
|||
| 300 | -7x | +|||
| 508 | +
- child_labels = "hidden"+ #' @inheritParams argument_convention |
|||
| 301 | +509 |
- )+ #' @inheritParams prop_strat_wilson |
||
| 302 | -7x | +|||
| 510 | +
- lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)+ #' |
|||
| 303 | -7x | +|||
| 511 | +
- lyt_or <- analyze_colvars(+ #' @return Stratified quantile. |
|||
| 304 | -7x | +|||
| 512 | +
- lyt = lyt_or,+ #' |
|||
| 305 | -7x | +|||
| 513 | +
- afun = afun_lst[names(colvars_or$labels)],+ #' @seealso [prop_strat_wilson()] |
|||
| 306 | -7x | +|||
| 514 | +
- na_str = na_str,+ #' |
|||
| 307 | -7x | +|||
| 515 | +
- inclNAs = TRUE,+ #' @examples |
|||
| 308 | -7x | +|||
| 516 | +
- extra_args = extra_args+ #' strata_data <- table(data.frame( |
|||
| 309 | +517 |
- )+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 310 | +518 |
- }+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 311 | -8x | +|||
| 519 | +
- table_or <- build_table(lyt_or, df = df$or)+ #' stringsAsFactors = TRUE |
|||
| 312 | +520 |
-
+ #' )) |
||
| 313 | -8x | +|||
| 521 | +
- n_tot_id <- match("n_tot", colvars_or$vars)
+ #' ns <- colSums(strata_data) |
|||
| 314 | -8x | +|||
| 522 | +
- if (is.null(table_prop)) {
+ #' ests <- strata_data["TRUE", ] / ns |
|||
| 315 | -! | +|||
| 523 | +
- result <- table_or+ #' vars <- ests * (1 - ests) / ns |
|||
| 316 | -! | +|||
| 524 | +
- or_id <- match("or", colvars_or$vars)
+ #' weights <- rep(1 / length(ns), length(ns)) |
|||
| 317 | -! | +|||
| 525 | +
- ci_id <- match("lcl", colvars_or$vars)
+ #' |
|||
| 318 | +526 |
- } else {
+ #' strata_normal_quantile(vars, weights, 0.95) |
||
| 319 | -8x | +|||
| 527 | +
- result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])+ #' |
|||
| 320 | -8x | +|||
| 528 | +
- or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
+ #' @export |
|||
| 321 | -8x | +|||
| 529 | +
- ci_id <- 1L + ncol(table_prop) + match("lcl", colvars_or$vars[-n_tot_id])
+ strata_normal_quantile <- function(vars, weights, conf_level) {
|
|||
| 322 | -8x | +530 | +41x |
- n_tot_id <- 1L+ summands <- weights^2 * vars |
| 323 | +531 |
- }+ # Stratified quantile |
||
| 324 | -8x | +532 | +41x |
- structure(+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2) |
| 325 | -8x | +|||
| 533 | +
- result,+ } |
|||
| 326 | -8x | +|||
| 534 | +
- forest_header = paste0(levels(df$prop$arm), "\nBetter"),+ |
|||
| 327 | -8x | +|||
| 535 | +
- col_x = or_id,+ #' Helper Function for the Estimation of Weights for `prop_strat_wilson` |
|||
| 328 | -8x | +|||
| 536 | +
- col_ci = ci_id,+ #' |
|||
| 329 | -8x | +|||
| 537 | +
- col_symbol_size = n_tot_id+ #' @description `r lifecycle::badge("stable")`
|
|||
| 330 | +538 |
- )+ #' |
||
| 331 | +539 |
- }+ #' This function wraps the iteration procedure that allows you to estimate |
||
| 332 | +540 |
-
+ #' the weights for each proportional strata. This assumes to minimize the |
||
| 333 | +541 |
- #' Labels for Column Variables in Binary Response by Subgroup Table+ #' weighted squared length of the confidence interval. |
||
| 334 | +542 |
#' |
||
| 335 | +543 |
- #' @description `r lifecycle::badge("stable")`
+ #' @inheritParams prop_strat_wilson |
||
| 336 | +544 |
- #'+ #' @param vars (`numeric`)\cr normalized proportions for each strata. |
||
| 337 | +545 |
- #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels.+ #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles. |
||
| 338 | +546 |
- #'+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can |
||
| 339 | +547 |
- #' @inheritParams argument_convention+ #' be optimized in the future if we need to estimate better initial weights. |
||
| 340 | +548 |
- #' @inheritParams tabulate_rsp_subgroups+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata. |
||
| 341 | +549 |
- #'+ #' @param max_iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked. |
||
| 342 | +550 |
- #' @return A `list` of variables to tabulate and their labels.+ #' @param tol (`number`)\cr tolerance threshold for convergence. |
||
| 343 | +551 |
#' |
||
| 344 | +552 |
- #' @export+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`. |
||
| 345 | +553 |
- d_rsp_subgroups_colvars <- function(vars,+ #' |
||
| 346 | +554 |
- conf_level = NULL,+ #' @seealso For references and details see [prop_strat_wilson()]. |
||
| 347 | +555 |
- method = NULL) {
+ #' |
||
| 348 | -17x | +|||
| 556 | +
- checkmate::assert_character(vars)+ #' @examples |
|||
| 349 | -17x | +|||
| 557 | +
- checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018) |
|||
| 350 | -17x | +|||
| 558 | +
- checkmate::assert_subset(+ #' sq <- 0.674 |
|||
| 351 | -17x | +|||
| 559 | +
- vars,+ #' ws <- rep(1 / length(vs), length(vs)) |
|||
| 352 | -17x | +|||
| 560 | +
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ #' ns <- c(22, 18, 17, 17, 14, 12) |
|||
| 353 | +561 |
- )+ #' |
||
| 354 | +562 |
-
+ #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001) |
||
| 355 | -17x | +|||
| 563 | +
- varlabels <- c(+ #' |
|||
| 356 | -17x | +|||
| 564 | +
- n = "n",+ #' @export |
|||
| 357 | -17x | +|||
| 565 | +
- n_rsp = "Responders",+ update_weights_strat_wilson <- function(vars, |
|||
| 358 | -17x | +|||
| 566 | +
- prop = "Response (%)",+ strata_qnorm, |
|||
| 359 | -17x | +|||
| 567 | +
- n_tot = "Total n",+ initial_weights, |
|||
| 360 | -17x | +|||
| 568 | +
- or = "Odds Ratio"+ n_per_strata, |
|||
| 361 | +569 |
- )+ max_iterations = 50, |
||
| 362 | -17x | +|||
| 570 | +
- colvars <- vars+ conf_level = 0.95, |
|||
| 363 | +571 |
-
+ tol = 0.001) {
|
||
| 364 | -17x | +572 | +8x |
- if ("ci" %in% colvars) {
+ it <- 0 |
| 365 | -17x | +573 | +8x |
- checkmate::assert_false(is.null(conf_level))+ diff_v <- NULL |
| 366 | +574 | |||
| 367 | -17x | +575 | +8x |
- varlabels <- c(+ while (it < max_iterations) {
|
| 368 | -17x | +576 | +19x |
- varlabels,+ it <- it + 1 |
| 369 | -17x | +577 | +19x |
- ci = paste0(100 * conf_level, "% CI")+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2 |
| 370 | -+ | |||
| 578 | +19x |
- )+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2)) |
||
| 371 | -+ | |||
| 579 | +19x |
-
+ weights_new <- weights_new_t / weights_new_b |
||
| 372 | -+ | |||
| 580 | +19x |
- # The `lcl`` variable is just a placeholder available in the analysis data,+ weights_new <- weights_new / sum(weights_new) |
||
| 373 | -+ | |||
| 581 | +19x |
- # it is not acutally used in the tabulation.+ strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level) |
||
| 374 | -+ | |||
| 582 | +19x |
- # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights))) |
||
| 375 | -17x | +583 | +8x |
- colvars[colvars == "ci"] <- "lcl"+ if (diff_v[length(diff_v)] < tol) break+ |
+
| 584 | +11x | +
+ initial_weights <- weights_new |
||
| 376 | +585 |
} |
||
| 377 | +586 | |||
| 378 | -17x | -
- if ("pval" %in% colvars) {
- |
- ||
| 379 | -13x | -
- varlabels <- c(- |
- ||
| 380 | -13x | -
- varlabels,- |
- ||
| 381 | -13x | +587 | +8x |
- pval = method+ if (it == max_iterations) {
|
| 382 | -+ | |||
| 588 | +! |
- )+ warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
|
||
| 383 | +589 |
} |
||
| 384 | +590 | |||
| 385 | -17x | +591 | +8x |
list( |
| 386 | -17x | +592 | +8x |
- vars = colvars,+ "n_it" = it, |
| 387 | -17x | +593 | +8x |
- labels = varlabels[vars]+ "weights" = weights_new,+ |
+
| 594 | +8x | +
+ "diff_v" = diff_v |
||
| 388 | +595 |
) |
||
| 389 | +596 |
}@@ -24085,14 +24386,14 @@ tern coverage - 90.46% |
| 1 |
- #' Split Function to Configure Risk Difference Column+ #' Tabulate Binary Response by Subgroup |
||
| 5 |
- #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference+ #' Tabulate statistics such as response rate and odds ratio for population subgroups. |
||
| 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+ #' @inheritParams extract_rsp_subgroups |
||
| 8 |
- #' `riskdiff` to `TRUE` in all following analyze function calls.+ #' @inheritParams argument_convention |
||
| 10 |
- #' @param arm_x (`character`)\cr Name of reference arm to use in risk difference calculations.+ #' @details These functions create a layout starting from a data frame which contains |
||
| 11 |
- #' @param arm_y (`character`)\cr Names of one or more arms to compare to reference arm in risk difference+ #' the required statistics. Tables typically used as part of forest plot. |
||
| 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.+ #' @seealso [extract_rsp_subgroups()] |
||
| 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).+ #' @examples |
||
| 16 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ #' library(dplyr) |
||
| 17 |
- #'+ #' library(forcats) |
||
| 18 |
- #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()]+ #' |
||
| 19 |
- #' when creating a table layout.+ #' adrs <- tern_ex_adrs |
||
| 20 |
- #'+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 21 |
- #' @seealso [stat_propdiff_ci()] for details on risk difference calculation.+ #' |
||
| 22 |
- #'+ #' adrs_f <- adrs %>% |
||
| 23 |
- #' @examples+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 24 |
- #' adae <- tern_ex_adae+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 25 |
- #' adae$AESEV <- factor(adae$AESEV)+ #' droplevels() %>% |
||
| 26 |
- #'+ #' mutate( |
||
| 27 |
- #' lyt <- basic_table() %>%+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 28 |
- #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 29 |
- #' count_occurrences_by_grade(+ #' rsp = AVALC == "CR" |
||
| 30 |
- #' var = "AESEV",+ #' ) |
||
| 31 |
- #' riskdiff = TRUE+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 32 |
- #' )+ #' |
||
| 33 |
- #'+ #' # Unstratified analysis. |
||
| 34 |
- #' tbl <- build_table(lyt, df = adae)+ #' df <- extract_rsp_subgroups( |
||
| 35 |
- #' tbl+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 36 |
- #'+ #' data = adrs_f |
||
| 37 |
- #' @export+ #' ) |
||
| 38 |
- add_riskdiff <- function(arm_x,+ #' df |
||
| 39 |
- arm_y,+ #' |
||
| 40 |
- col_label = paste0(+ #' # Stratified analysis. |
||
| 41 |
- "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
+ #' df_strat <- extract_rsp_subgroups( |
||
| 42 |
- ),+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"),
|
||
| 43 |
- pct = TRUE) {
+ #' data = adrs_f |
||
| 44 | -7x | +
- checkmate::assert_character(arm_x, len = 1)+ #' ) |
|
| 45 | -7x | +
- checkmate::assert_character(arm_y, min.len = 1)+ #' df_strat |
|
| 46 | -7x | +
- checkmate::assert_character(col_label, len = length(arm_y))+ #' |
|
| 47 |
-
+ #' # Grouping of the BMRKR2 levels. |
||
| 48 | -7x | +
- combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs)+ #' df_grouped <- extract_rsp_subgroups( |
|
| 49 | -7x | +
- for (i in seq_len(length(arm_y))) {
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|
| 50 | -7x | +
- combodf <- rbind(+ #' data = adrs_f, |
|
| 51 | -7x | +
- combodf,+ #' groups_lists = list( |
|
| 52 | -7x | +
- tibble::tribble(+ #' BMRKR2 = list( |
|
| 53 | -7x | +
- ~valname, ~label, ~levelcombo, ~exargs,+ #' "low" = "LOW", |
|
| 54 | -7x | +
- paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|
| 55 |
- )+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 56 |
- )+ #' ) |
||
| 57 |
- }+ #' ) |
||
| 58 | -7x | +
- if (pct) combodf$valname <- paste0(combodf$valname, "_pct")+ #' ) |
|
| 59 | -7x | +
- add_combo_levels(combodf)+ #' df_grouped |
|
| 60 |
- }+ #' |
||
| 61 |
-
+ #' @name response_subgroups |
||
| 62 |
- #' Analysis Function to Calculate Risk Difference Column Values+ #' @order 1 |
||
| 63 |
- #'+ NULL |
||
| 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+ #' Prepares Response Data for Population Subgroups in Data Frames |
||
| 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+ #' @description `r lifecycle::badge("stable")`
|
||
| 68 |
- #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations.+ #' |
||
| 69 |
- #'+ #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper |
||
| 70 |
- #' @inheritParams argument_convention+ #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two |
||
| 71 |
- #' @param afun (named `list`)\cr A named list containing one name-value pair where the name corresponds to+ #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`, |
||
| 72 |
- #' the name of the statistics function that should be used in calculations and the value is the corresponding+ #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`. |
||
| 73 |
- #' analysis function.+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 74 |
- #' @param s_args (named `list`)\cr Additional arguments to be passed to the statistics function and analysis+ #' |
||
| 75 |
- #' function supplied in `afun`.+ #' @inheritParams argument_convention |
||
| 76 |
- #'+ #' @inheritParams response_subgroups |
||
| 77 |
- #' @return A list of formatted [rtables::CellValue()].+ #' @param label_all (`string`)\cr label for the total population analysis. |
||
| 79 |
- #' @seealso+ #' @return A named list of two elements: |
||
| 80 |
- #' * [stat_propdiff_ci()] for details on risk difference calculation.+ #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`, |
||
| 81 |
- #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with+ #' `var_label`, and `row_type`. |
||
| 82 |
- #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column+ #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, |
||
| 83 |
- #' to a table layout.+ #' `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 85 |
- #' @keywords internal+ #' @seealso [response_subgroups] |
||
| 86 |
- afun_riskdiff <- function(df,+ #' |
||
| 87 |
- labelstr = "",+ #' @export |
||
| 88 |
- .var,+ extract_rsp_subgroups <- function(variables, |
||
| 89 |
- .N_col, # nolint+ data, |
||
| 90 |
- .N_row, # nolint+ groups_lists = list(), |
||
| 91 |
- .df_row,+ conf_level = 0.95, |
||
| 92 |
- .spl_context,+ method = NULL, |
||
| 93 |
- .all_col_counts,+ label_all = "All Patients") {
|
||
| 94 | -+ | 11x |
- .stats,+ if ("strat" %in% names(variables)) {
|
| 95 | -+ | ! |
- .formats = NULL,+ warning( |
| 96 | -+ | ! |
- .labels = NULL,+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ", |
| 97 | -+ | ! |
- .indent_mods = NULL,+ "was deprecated in tern 0.9.3.\n ", |
| 98 | -+ | ! |
- na_str = default_na_str(),+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
| 99 |
- afun,+ ) |
||
| 100 | -+ | ! |
- s_args = list()) {
+ variables[["strata"]] <- variables[["strat"]] |
| 101 | -44x | +
- if (!any(grepl("riskdiff", names(.spl_context)))) {
+ } |
|
| 102 | -! | +
- stop(+ |
|
| 103 | -! | +11x |
- "Please set up levels to use in risk difference calculations using the `add_riskdiff` ",+ df_prop <- h_proportion_subgroups_df( |
| 104 | -! | +11x |
- "split function within `split_cols_by`. See ?add_riskdiff for details."+ variables, |
| 105 | -+ | 11x |
- )+ data, |
| 106 | -+ | 11x |
- }+ groups_lists = groups_lists, |
| 107 | -44x | +11x |
- checkmate::assert_list(afun, len = 1, types = "function")+ label_all = label_all |
| 108 | -44x | +
- checkmate::assert_named(afun)+ ) |
|
| 109 | -44x | +11x |
- afun_args <- list(+ df_or <- h_odds_ratio_subgroups_df( |
| 110 | -44x | +11x |
- .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr,+ variables, |
| 111 | -44x | +11x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ data, |
| 112 | -+ | 11x |
- )+ groups_lists = groups_lists, |
| 113 | -44x | +11x |
- afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))]+ conf_level = conf_level, |
| 114 | -! | +11x |
- if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
+ method = method, |
| 115 | -+ | 11x |
-
+ label_all = label_all |
| 116 | -44x | +
- cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1)+ ) |
|
| 117 | -44x | +
- if (!grepl("^riskdiff", cur_split)) {
+
|
|
| 118 | -+ | 11x |
- # Apply basic afun (no risk difference) in all other columns+ list(prop = df_prop, or = df_or) |
| 119 | -33x | +
- do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args))+ } |
|
| 120 |
- } else {
+
|
||
| 121 | -11x | +
- arm_x <- strsplit(cur_split, "_")[[1]][2]+ #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`. |
|
| 122 | -11x | +
- arm_y <- strsplit(cur_split, "_")[[1]][3]+ #' |
|
| 123 | -11x | +
- if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
+ #' @return |
|
| 124 | -! | +
- arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
+ #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 125 | -! | +
- arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
+ #' |
|
| 126 |
- } else {
+ #' @keywords internal |
||
| 127 | -11x | +
- arm_spl_x <- arm_x+ a_response_subgroups <- function(.formats = list( |
|
| 128 | -11x | +
- arm_spl_y <- arm_y+ n = "xx", # nolint start |
|
| 129 |
- }+ n_rsp = "xx", |
||
| 130 | -11x | +
- N_col_x <- .all_col_counts[[arm_spl_x]] # nolint+ prop = "xx.x%", |
|
| 131 | -11x | +
- N_col_y <- .all_col_counts[[arm_spl_y]] # nolint+ n_tot = "xx", |
|
| 132 | -11x | +
- cur_var <- tail(.spl_context$cur_col_split[[1]], 1)+ or = list(format_extreme_values(2L)), |
|
| 133 |
-
+ ci = list(format_extreme_values_ci(2L)), |
||
| 134 |
- # Apply statistics function to arm X and arm Y data+ pval = "x.xxxx | (<0.0001)" # nolint end |
||
| 135 | -11x | +
- s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))])+ ), |
|
| 136 | -11x | +
- s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args))+ na_str = default_na_str()) {
|
|
| 137 | -11x | +17x |
- s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args))+ checkmate::assert_list(.formats) |
| 138 | -+ | 17x |
-
+ checkmate::assert_subset( |
| 139 | -+ | 17x |
- # Get statistic name and row names+ names(.formats), |
| 140 | -11x | +17x |
- stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
|
| 141 | -11x | +
- if ("flag_variables" %in% names(s_args)) {
+ ) |
|
| 142 | -1x | +
- var_nms <- s_args$flag_variables+ |
|
| 143 | -10x | +17x |
- } else if (!is.null(names(s_x[[stat]]))) {
+ afun_lst <- Map( |
| 144 | -4x | +17x |
- var_nms <- names(s_x[[stat]])+ function(stat, fmt, na_str) {
|
| 145 | -+ | 114x |
- } else {
+ if (stat == "ci") {
|
| 146 | -6x | +16x |
- var_nms <- ""+ function(df, labelstr = "", ...) {
|
| 147 | -6x | +36x |
- s_x[[stat]] <- list(s_x[[stat]])+ in_rows( |
| 148 | -6x | +36x |
- s_y[[stat]] <- list(s_y[[stat]])+ .list = combine_vectors(df$lcl, df$ucl), |
| 149 | -+ | 36x |
- }+ .labels = as.character(df$subgroup), |
| 150 | -+ | 36x |
-
+ .formats = fmt, |
| 151 | -+ | 36x |
- # Calculate risk difference for each row, repeated if multiple statistics in table+ .format_na_strs = na_str |
| 152 | -11x | +
- pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct"+ ) |
|
| 153 | -11x | +
- rd_ci <- rep(stat_propdiff_ci(+ } |
|
| 154 | -11x | +
- lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1),+ } else {
|
|
| 155 | -11x | +98x |
- N_col_x, N_col_y,+ function(df, labelstr = "", ...) {
|
| 156 | -11x | +211x |
- list_names = var_nms,+ in_rows( |
| 157 | -11x | +211x |
- pct = pct+ .list = as.list(df[[stat]]), |
| 158 | -11x | +211x |
- ), max(1, length(.stats)))+ .labels = as.character(df$subgroup), |
| 159 | -+ | 211x |
-
+ .formats = fmt, |
| 160 | -11x | +211x |
- in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods)+ .format_na_strs = na_str |
| 161 |
- }+ ) |
||
| 162 |
- }- |
-
| 1 | -- |
- #' Cox Regression Helper: Interactions- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +163 |
- #'+ } |
||
| 5 | +164 |
- #' Test and estimate the effect of a treatment in interaction with a covariate.+ }, |
||
| 6 | -+ | |||
| 165 | +17x |
- #' The effect is estimated as the HR of the tested treatment for a given level+ stat = names(.formats), |
||
| 7 | -+ | |||
| 166 | +17x |
- #' of the covariate, in comparison to the treatment control.+ fmt = .formats, |
||
| 8 | -+ | |||
| 167 | +17x |
- #'+ na_str = na_str |
||
| 9 | +168 |
- #' @inheritParams argument_convention+ ) |
||
| 10 | +169 |
- #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested.+ |
||
| 11 | -+ | |||
| 170 | +17x |
- #' @param effect (`string`)\cr the name of the effect to be tested and estimated.+ afun_lst |
||
| 12 | +171 |
- #' @param covar (`string`)\cr the name of the covariate in the model.+ } |
||
| 13 | +172 |
- #' @param mod (`coxph`)\cr the Cox regression model.+ |
||
| 14 | +173 |
- #' @param label (`string`)\cr the label to be returned as `term_label`.+ #' @describeIn response_subgroups Table-creating function which creates a table |
||
| 15 | +174 |
- #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()].+ #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
||
| 16 | +175 |
- #' @param ... see methods.+ #' and [rtables::summarize_row_groups()]. |
||
| 17 | +176 |
#' |
||
| 18 | -- |
- #' @examples- |
- ||
| 19 | +177 |
- #' library(survival)+ #' @param df (`list`)\cr of data frames containing all analysis variables. List should be |
||
| 20 | +178 |
- #'+ #' created using [extract_rsp_subgroups()]. |
||
| 21 | +179 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 22 | +180 |
- #'+ #' * `n`: Total number of observations per group. |
||
| 23 | +181 |
- #' # Testing dataset [survival::bladder].+ #' * `n_rsp`: Number of responders per group. |
||
| 24 | +182 |
- #' dta_bladder <- with(+ #' * `prop`: Proportion of responders. |
||
| 25 | +183 |
- #' data = bladder[bladder$enum < 5, ],+ #' * `n_tot`: Total number of observations. |
||
| 26 | +184 |
- #' data.frame(+ #' * `or`: Odds ratio. |
||
| 27 | +185 |
- #' time = stop,+ #' * `ci` : Confidence interval of odds ratio. |
||
| 28 | +186 |
- #' status = event,+ #' * `pval`: p-value of the effect. |
||
| 29 | +187 |
- #' armcd = as.factor(rx),+ #' Note, the statistics `n_tot`, `or` and `ci` are required. |
||
| 30 | +188 |
- #' covar1 = as.factor(enum),+ #' |
||
| 31 | +189 |
- #' covar2 = factor(+ #' @return An `rtables` table summarizing binary response by subgroup. |
||
| 32 | +190 |
- #' sample(as.factor(enum)),+ #' |
||
| 33 | +191 |
- #' levels = 1:4,+ #' @examples |
||
| 34 | +192 |
- #' labels = c("F", "F", "M", "M")
+ #' ## Table with default columns. |
||
| 35 | +193 |
- #' )+ #' basic_table() %>% |
||
| 36 | +194 |
- #' )+ #' tabulate_rsp_subgroups(df) |
||
| 37 | +195 |
- #' )+ #' |
||
| 38 | +196 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ #' ## Table with selected columns. |
||
| 39 | +197 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ #' basic_table() %>% |
||
| 40 | +198 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' tabulate_rsp_subgroups( |
||
| 41 | +199 |
- #'+ #' df = df, |
||
| 42 | +200 |
- #' plot(+ #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
|
||
| 43 | +201 |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ #' ) |
||
| 44 | +202 |
- #' lty = 2:4,+ #' |
||
| 45 | +203 |
- #' xlab = "Months",+ #' @export |
||
| 46 | +204 |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ #' @order 2 |
||
| 47 | +205 |
- #' )+ tabulate_rsp_subgroups <- function(lyt, |
||
| 48 | +206 |
- #'+ df, |
||
| 49 | +207 |
- #' @name cox_regression_inter+ vars = c("n_tot", "n", "prop", "or", "ci"),
|
||
| 50 | +208 |
- NULL+ groups_lists = list(), |
||
| 51 | +209 |
-
+ label_all = "All Patients", |
||
| 52 | +210 |
- #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect.+ na_str = default_na_str()) {
|
||
| 53 | -+ | |||
| 211 | +8x |
- #'+ conf_level <- df$or$conf_level[1] |
||
| 54 | -+ | |||
| 212 | +8x |
- #' @return+ method <- if ("pval_label" %in% names(df$or)) {
|
||
| 55 | -+ | |||
| 213 | +5x |
- #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following+ df$or$pval_label[1] |
||
| 56 | +214 |
- #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`.+ } else {
|
||
| 57 | -+ | |||
| 215 | +3x |
- #'+ NULL |
||
| 58 | +216 |
- #' @export+ } |
||
| 59 | +217 |
- h_coxreg_inter_effect <- function(x,+ |
||
| 60 | -+ | |||
| 218 | +8x |
- effect,+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all) |
||
| 61 | +219 |
- covar,+ |
||
| 62 | -+ | |||
| 220 | +8x |
- mod,+ afun_lst <- a_response_subgroups(na_str = na_str) |
||
| 63 | -+ | |||
| 221 | +8x |
- label,+ colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method) |
||
| 64 | +222 |
- control,+ |
||
| 65 | -+ | |||
| 223 | +8x |
- ...) {
+ colvars_prop <- list( |
||
| 66 | -26x | +224 | +8x |
- UseMethod("h_coxreg_inter_effect", x)
+ vars = colvars$vars[names(colvars$labels) %in% c("n", "prop", "n_rsp")],
|
| 67 | -+ | |||
| 225 | +8x |
- }+ labels = colvars$labels[names(colvars$labels) %in% c("n", "prop", "n_rsp")]
|
||
| 68 | +226 |
-
+ ) |
||
| 69 | -+ | |||
| 227 | +8x |
- #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate.+ colvars_or <- list( |
||
| 70 | -+ | |||
| 228 | +8x |
- #'+ vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")],
|
||
| 71 | -+ | |||
| 229 | +8x |
- #' @method h_coxreg_inter_effect numeric+ labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")]
|
||
| 72 | +230 |
- #'+ ) |
||
| 73 | +231 |
- #' @param at (`list`)\cr a list with items named after the covariate, every+ |
||
| 74 | +232 |
- #' item is a vector of levels at which the interaction should be estimated.+ # Columns from table_prop are optional. |
||
| 75 | -+ | |||
| 233 | +8x |
- #'+ if (length(colvars_prop$vars) > 0) {
|
||
| 76 | -+ | |||
| 234 | +8x |
- #' @export+ lyt_prop <- split_cols_by(lyt = lyt, var = "arm") |
||
| 77 | -+ | |||
| 235 | +8x |
- h_coxreg_inter_effect.numeric <- function(x,+ lyt_prop <- split_cols_by_multivar( |
||
| 78 | -+ | |||
| 236 | +8x |
- effect,+ lyt = lyt_prop, |
||
| 79 | -+ | |||
| 237 | +8x |
- covar,+ vars = colvars_prop$vars, |
||
| 80 | -+ | |||
| 238 | +8x |
- mod,+ varlabels = colvars_prop$labels |
||
| 81 | +239 |
- label,+ ) |
||
| 82 | +240 |
- control,+ |
||
| 83 | +241 |
- at,+ # "All Patients" row |
||
| 84 | -+ | |||
| 242 | +8x |
- ...) {
+ lyt_prop <- split_rows_by( |
||
| 85 | -7x | +243 | +8x |
- betas <- stats::coef(mod)+ lyt = lyt_prop, |
| 86 | -7x | +244 | +8x |
- attrs <- attr(stats::terms(mod), "term.labels")+ var = "row_type", |
| 87 | -7x | +245 | +8x |
- term_indices <- grep(+ split_fun = keep_split_levels("content"),
|
| 88 | -7x | +246 | +8x |
- pattern = effect,+ nested = FALSE, |
| 89 | -7x | +247 | +8x |
- x = attrs[!grepl("strata\\(", attrs)]
+ child_labels = "hidden" |
| 90 | +248 |
- )+ ) |
||
| 91 | -7x | +249 | +8x |
- checkmate::assert_vector(term_indices, len = 2)+ lyt_prop <- analyze_colvars( |
| 92 | -7x | +250 | +8x |
- betas <- betas[term_indices]+ lyt = lyt_prop, |
| 93 | -7x | +251 | +8x |
- betas_var <- diag(stats::vcov(mod))[term_indices]+ afun = afun_lst[names(colvars_prop$labels)], |
| 94 | -7x | +252 | +8x |
- betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]+ na_str = na_str, |
| 95 | -7x | +253 | +8x |
- xval <- if (is.null(at[[covar]])) {
+ extra_args = extra_args |
| 96 | -6x | +|||
| 254 | +
- stats::median(x)+ ) |
|||
| 97 | +255 |
- } else {
+
|
||
| 98 | -1x | -
- at[[covar]]- |
- ||
| 99 | -+ | 256 | +8x |
- }+ if ("analysis" %in% df$prop$row_type) {
|
| 100 | +257 | 7x |
- effect_index <- !grepl(covar, names(betas))+ lyt_prop <- split_rows_by( |
|
| 101 | +258 | 7x |
- coef_hat <- betas[effect_index] + xval * betas[!effect_index]+ lyt = lyt_prop, |
|
| 102 | +259 | 7x |
- coef_se <- sqrt(+ var = "row_type", |
|
| 103 | +260 | 7x |
- betas_var[effect_index] ++ split_fun = keep_split_levels("analysis"),
|
|
| 104 | +261 | 7x |
- xval ^ 2 * betas_var[!effect_index] + # styler: off+ nested = FALSE, |
|
| 105 | +262 | 7x |
- 2 * xval * betas_cov+ child_labels = "hidden" |
|
| 106 | +263 |
- )+ ) |
||
| 107 | +264 | 7x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE) |
|
| 108 | +265 | 7x |
- data.frame(+ lyt_prop <- analyze_colvars( |
|
| 109 | +266 | 7x |
- effect = "Covariate:",+ lyt = lyt_prop, |
|
| 110 | +267 | 7x |
- term = rep(covar, length(xval)),+ afun = afun_lst[names(colvars_prop$labels)], |
|
| 111 | +268 | 7x |
- term_label = paste0(" ", xval),
+ na_str = na_str, |
|
| 112 | +269 | 7x |
- level = as.character(xval),+ inclNAs = TRUE, |
|
| 113 | +270 | 7x |
- n = NA,+ extra_args = extra_args |
|
| 114 | -7x | +|||
| 271 | +
- hr = exp(coef_hat),+ ) |
|||
| 115 | -7x | +|||
| 272 | +
- 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 | +273 | |||
| 123 | -- |
- #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate.- |
- ||
| 124 | -+ | |||
| 274 | +8x |
- #'+ table_prop <- build_table(lyt_prop, df = df$prop) |
||
| 125 | +275 |
- #' @method h_coxreg_inter_effect factor+ } else {
|
||
| 126 | -+ | |||
| 276 | +! |
- #'+ table_prop <- NULL |
||
| 127 | +277 |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ } |
||
| 128 | +278 |
- #'+ |
||
| 129 | +279 |
- #' @export+ # Columns "n_tot", "or", "ci" in table_or are required. |
||
| 130 | -+ | |||
| 280 | +8x |
- h_coxreg_inter_effect.factor <- function(x,+ lyt_or <- split_cols_by(lyt = lyt, var = "arm") |
||
| 131 | -+ | |||
| 281 | +8x |
- effect,+ lyt_or <- split_cols_by_multivar( |
||
| 132 | -+ | |||
| 282 | +8x |
- covar,+ lyt = lyt_or, |
||
| 133 | -+ | |||
| 283 | +8x |
- mod,+ vars = colvars_or$vars, |
||
| 134 | -+ | |||
| 284 | +8x |
- label,+ varlabels = colvars_or$labels |
||
| 135 | +285 |
- control,+ ) |
||
| 136 | +286 |
- data,+ |
||
| 137 | +287 |
- ...) {
- |
- ||
| 138 | -15x | -
- lvl_given <- levels(x)- |
- ||
| 139 | -15x | -
- y <- h_coxreg_inter_estimations(+ # "All Patients" row |
||
| 140 | -15x | +288 | +8x |
- variable = effect, given = covar,+ lyt_or <- split_rows_by( |
| 141 | -15x | +289 | +8x |
- lvl_var = levels(data[[effect]]),+ lyt = lyt_or, |
| 142 | -15x | +290 | +8x |
- lvl_given = lvl_given,+ var = "row_type", |
| 143 | -15x | +291 | +8x |
- mod = mod,+ split_fun = keep_split_levels("content"),
|
| 144 | -15x | +292 | +8x |
- conf_level = 0.95+ nested = FALSE, |
| 145 | -15x | +293 | +8x |
- )[[1]]+ child_labels = "hidden" |
| 146 | +294 |
-
+ ) |
||
| 147 | -15x | +295 | +8x |
- data.frame(+ lyt_or <- analyze_colvars( |
| 148 | -15x | +296 | +8x |
- effect = "Covariate:",+ lyt = lyt_or, |
| 149 | -15x | +297 | +8x |
- term = rep(covar, nrow(y)),+ afun = afun_lst[names(colvars_or$labels)], |
| 150 | -15x | +298 | +8x |
- term_label = paste0(" ", lvl_given),
+ na_str = na_str, |
| 151 | -15x | +299 | +8x |
- level = lvl_given,+ extra_args = extra_args |
| 152 | -15x | +|||
| 300 | +
- n = NA,+ ) %>% |
|||
| 153 | -15x | +301 | +8x |
- hr = y[, "hr"],+ append_topleft("Baseline Risk Factors")
|
| 154 | -15x | +|||
| 302 | +
- lcl = y[, "lcl"],+ |
|||
| 155 | -15x | +303 | +8x |
- ucl = y[, "ucl"],+ if ("analysis" %in% df$or$row_type) {
|
| 156 | -15x | +304 | +7x |
- pval = NA,+ lyt_or <- split_rows_by( |
| 157 | -15x | +305 | +7x |
- pval_inter = NA,+ lyt = lyt_or, |
| 158 | -15x | +306 | +7x |
- stringsAsFactors = FALSE+ var = "row_type", |
| 159 | -+ | |||
| 307 | +7x |
- )+ split_fun = keep_split_levels("analysis"),
|
||
| 160 | -+ | |||
| 308 | +7x |
- }+ nested = FALSE, |
||
| 161 | -+ | |||
| 309 | +7x |
-
+ child_labels = "hidden" |
||
| 162 | +310 |
- #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate.+ ) |
||
| 163 | -+ | |||
| 311 | +7x |
- #' This makes an automatic conversion to `factor` and then forwards to the method for factors.+ lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE) |
||
| 164 | -+ | |||
| 312 | +7x |
- #'+ lyt_or <- analyze_colvars( |
||
| 165 | -+ | |||
| 313 | +7x |
- #' @method h_coxreg_inter_effect character+ lyt = lyt_or, |
||
| 166 | -+ | |||
| 314 | +7x |
- #'+ afun = afun_lst[names(colvars_or$labels)], |
||
| 167 | -+ | |||
| 315 | +7x |
- #' @note+ na_str = na_str, |
||
| 168 | -+ | |||
| 316 | +7x |
- #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is+ inclNAs = TRUE, |
||
| 169 | -+ | |||
| 317 | +7x |
- #' therefore better to always pre-process the dataset such that factors are manually created from character+ extra_args = extra_args |
||
| 170 | +318 |
- #' variables before passing the dataset to [rtables::build_table()].+ ) |
||
| 171 | +319 |
- #'+ } |
||
| 172 | -+ | |||
| 320 | +8x |
- #' @export+ table_or <- build_table(lyt_or, df = df$or) |
||
| 173 | +321 |
- h_coxreg_inter_effect.character <- function(x,+ |
||
| 174 | -+ | |||
| 322 | +8x |
- effect,+ n_tot_id <- match("n_tot", colvars_or$vars)
|
||
| 175 | -+ | |||
| 323 | +8x |
- covar,+ if (is.null(table_prop)) {
|
||
| 176 | -+ | |||
| 324 | +! |
- mod,+ result <- table_or |
||
| 177 | -+ | |||
| 325 | +! |
- label,+ or_id <- match("or", colvars_or$vars)
|
||
| 178 | -+ | |||
| 326 | +! |
- control,+ ci_id <- match("lcl", colvars_or$vars)
|
||
| 179 | +327 |
- data,+ } else {
|
||
| 180 | -+ | |||
| 328 | +8x |
- ...) {
+ result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id]) |
||
| 181 | -4x | +329 | +8x |
- y <- as.factor(x)+ or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
|
| 182 | -+ | |||
| 330 | +8x |
-
+ ci_id <- 1L + ncol(table_prop) + match("lcl", colvars_or$vars[-n_tot_id])
|
||
| 183 | -4x | +331 | +8x |
- h_coxreg_inter_effect(+ n_tot_id <- 1L |
| 184 | -4x | +|||
| 332 | +
- x = y,+ } |
|||
| 185 | -4x | +333 | +8x |
- effect = effect,+ structure( |
| 186 | -4x | +334 | +8x |
- covar = covar,+ result, |
| 187 | -4x | +335 | +8x |
- mod = mod,+ forest_header = paste0(levels(df$prop$arm), "\nBetter"), |
| 188 | -4x | +336 | +8x |
- label = label,+ col_x = or_id, |
| 189 | -4x | +337 | +8x |
- control = control,+ col_ci = ci_id, |
| 190 | -4x | +338 | +8x |
- data = data,+ col_symbol_size = n_tot_id |
| 191 | +339 |
- ...+ ) |
||
| 192 | +340 |
- )+ } |
||
| 193 | +341 |
- }+ |
||
| 194 | +342 |
-
+ #' Labels for Column Variables in Binary Response by Subgroup Table |
||
| 195 | +343 |
- #' @describeIn cox_regression_inter A higher level function to get+ #' |
||
| 196 | +344 |
- #' the results of the interaction test and the estimated values.+ #' @description `r lifecycle::badge("stable")`
|
||
| 197 | +345 |
#' |
||
| 198 | +346 |
- #' @return+ #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels. |
||
| 199 | +347 |
- #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If+ #' |
||
| 200 | +348 |
- #' no interaction, [h_coxreg_univar_extract()] is applied instead.+ #' @inheritParams argument_convention |
||
| 201 | +349 |
- #'+ #' @inheritParams tabulate_rsp_subgroups |
||
| 202 | +350 |
- #' @examples+ #' |
||
| 203 | +351 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' @return A `list` of variables to tabulate and their labels. |
||
| 204 | +352 |
- #' h_coxreg_extract_interaction(+ #' |
||
| 205 | +353 |
- #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder,+ #' @export |
||
| 206 | +354 |
- #' control = control_coxreg()+ d_rsp_subgroups_colvars <- function(vars, |
||
| 207 | +355 |
- #' )+ conf_level = NULL, |
||
| 208 | +356 |
- #'+ method = NULL) {
|
||
| 209 | -+ | |||
| 357 | +17x |
- #' @export+ checkmate::assert_character(vars) |
||
| 210 | -+ | |||
| 358 | +17x |
- h_coxreg_extract_interaction <- function(effect,+ checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
|
||
| 211 | -+ | |||
| 359 | +17x |
- covar,+ checkmate::assert_subset( |
||
| 212 | -+ | |||
| 360 | +17x |
- mod,+ vars, |
||
| 213 | -+ | |||
| 361 | +17x |
- data,+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
|
||
| 214 | +362 |
- at,+ ) |
||
| 215 | +363 |
- control) {
+
|
||
| 216 | -27x | +364 | +17x |
- if (!any(attr(stats::terms(mod), "order") == 2)) {
+ varlabels <- c( |
| 217 | -10x | +365 | +17x |
- y <- h_coxreg_univar_extract(+ n = "n", |
| 218 | -10x | +366 | +17x |
- effect = effect, covar = covar, mod = mod, data = data, control = control+ n_rsp = "Responders", |
| 219 | -+ | |||
| 367 | +17x |
- )+ prop = "Response (%)", |
||
| 220 | -10x | +368 | +17x |
- y$pval_inter <- NA+ n_tot = "Total n", |
| 221 | -10x | +369 | +17x |
- y+ or = "Odds Ratio" |
| 222 | +370 |
- } else {
+ ) |
||
| 223 | +371 | 17x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ colvars <- vars |
|
| 224 | +372 | |||
| 225 | -- |
- # Test the main treatment effect.- |
- ||
| 226 | -17x | -
- mod_aov <- muffled_car_anova(mod, test_statistic)- |
- ||
| 227 | +373 | 17x |
- sum_anova <- broom::tidy(mod_aov)+ if ("ci" %in% colvars) {
|
|
| 228 | +374 | 17x |
- pval <- sum_anova[sum_anova$term == effect, ][["p.value"]]+ checkmate::assert_false(is.null(conf_level)) |
|
| 229 | +375 | |||
| 230 | -- |
- # Test the interaction effect.- |
- ||
| 231 | +376 | 17x |
- pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
+ varlabels <- c( |
|
| 232 | +377 | 17x |
- covar_test <- data.frame(+ varlabels, |
|
| 233 | +378 | 17x |
- effect = "Covariate:",+ ci = paste0(100 * conf_level, "% CI") |
|
| 234 | -17x | +|||
| 379 | +
- term = covar,+ ) |
|||
| 235 | -17x | +|||
| 380 | +
- term_label = unname(labels_or_names(data[covar])),+ |
|||
| 236 | -17x | +|||
| 381 | +
- level = "",+ # The `lcl`` variable is just a placeholder available in the analysis data, |
|||
| 237 | -17x | +|||
| 382 | +
- n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval,+ # it is not acutally used in the tabulation. |
|||
| 238 | -17x | +|||
| 383 | +
- pval_inter = pval_inter,+ # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details. |
|||
| 239 | +384 | 17x |
- stringsAsFactors = FALSE+ colvars[colvars == "ci"] <- "lcl" |
|
| 240 | +385 |
- )+ } |
||
| 241 | +386 |
- # Estimate the interaction.+ |
||
| 242 | +387 | 17x |
- y <- h_coxreg_inter_effect(+ if ("pval" %in% colvars) {
|
|
| 243 | -17x | +388 | +13x |
- data[[covar]],+ varlabels <- c( |
| 244 | -17x | +389 | +13x |
- covar = covar,+ varlabels, |
| 245 | -17x | +390 | +13x |
- effect = effect,+ pval = method |
| 246 | -17x | +|||
| 391 | +
- mod = mod,+ ) |
|||
| 247 | -17x | +|||
| 392 | +
- label = unname(labels_or_names(data[covar])),+ }+ |
+ |||
| 393 | ++ | + | ||
| 248 | +394 | 17x |
- at = at,+ list( |
|
| 249 | +395 | 17x |
- control = control,+ vars = colvars, |
|
| 250 | +396 | 17x |
- data = data+ labels = varlabels[vars] |
|
| 251 | +397 |
- )- |
- ||
| 252 | -17x | -
- rbind(covar_test, y)+ ) |
||
| 253 | +398 |
- }+ } |
| 254 | +1 |
- }+ #' Split Function to Configure Risk Difference Column |
||
| 255 | +2 |
-
+ #' |
||
| 256 | +3 |
- #' @describeIn cox_regression_inter Hazard ratio estimation in interactions.+ #' @description `r lifecycle::badge("stable")`
|
||
| 257 | +4 |
#' |
||
| 258 | +5 |
- #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation+ #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference |
||
| 259 | +6 |
- #' of the levels of `variable` given the levels of `given`.+ #' column to be added to an `rtables` object. To add a risk difference column to a table, this function |
||
| 260 | +7 |
- #' @param lvl_var,lvl_given (`character`)\cr corresponding levels has given by [levels()].+ #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument |
||
| 261 | +8 |
- #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]).+ #' `riskdiff` to `TRUE` in all following analyze function calls. |
||
| 262 | +9 |
#' |
||
| 263 | +10 |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ #' @param arm_x (`character`)\cr Name of reference arm to use in risk difference calculations. |
||
| 264 | +11 |
- #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex.+ #' @param arm_y (`character`)\cr Names of one or more arms to compare to reference arm in risk difference |
||
| 265 | +12 |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ #' calculations. A new column will be added for each value of `arm_y`. |
||
| 266 | +13 |
- #'+ #' @param col_label (`character`)\cr Labels to use when rendering the risk difference column within the table. |
||
| 267 | +14 |
- #' - b1 (arm b), b2 (arm c)+ #' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are |
||
| 268 | +15 |
- #' - b3 (sex m)+ #' being compared (reference arm vs. comparison arm). |
||
| 269 | +16 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
||
| 270 | +17 |
#' |
||
| 271 | +18 |
- #' The estimation of the Hazard Ratio for arm C/sex M is given in reference+ #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()] |
||
| 272 | +19 |
- #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5).+ #' when creating a table layout. |
||
| 273 | +20 |
- #' The interaction coefficient is deduced by b2 + b5 while the standard error+ #' |
||
| 274 | +21 |
- #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$.+ #' @seealso [stat_propdiff_ci()] for details on risk difference calculation. |
||
| 275 | +22 |
#' |
||
| 276 | +23 |
- #' @return+ #' @examples |
||
| 277 | +24 |
- #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding+ #' adae <- tern_ex_adae |
||
| 278 | +25 |
- #' to the combinations of `variable` and `given`, with columns:+ #' adae$AESEV <- factor(adae$AESEV) |
||
| 279 | +26 |
- #' * `coef_hat`: Estimation of the coefficient.+ #' |
||
| 280 | +27 |
- #' * `coef_se`: Standard error of the estimation.+ #' lyt <- basic_table() %>% |
||
| 281 | +28 |
- #' * `hr`: Hazard ratio.+ #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
|
||
| 282 | +29 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ #' count_occurrences_by_grade( |
||
| 283 | +30 |
- #'+ #' var = "AESEV", |
||
| 284 | +31 |
- #' @examples+ #' riskdiff = TRUE |
||
| 285 | +32 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' ) |
||
| 286 | +33 |
- #' result <- h_coxreg_inter_estimations(+ #' |
||
| 287 | +34 |
- #' variable = "armcd", given = "covar1",+ #' tbl <- build_table(lyt, df = adae) |
||
| 288 | +35 |
- #' lvl_var = levels(dta_bladder$armcd),+ #' tbl |
||
| 289 | +36 |
- #' lvl_given = levels(dta_bladder$covar1),+ #' |
||
| 290 | +37 |
- #' mod = mod, conf_level = .95+ #' @export |
||
| 291 | +38 |
- #' )+ add_riskdiff <- function(arm_x, |
||
| 292 | +39 |
- #' result+ arm_y, |
||
| 293 | +40 |
- #'+ col_label = paste0( |
||
| 294 | +41 |
- #' @export+ "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
|
||
| 295 | +42 |
- h_coxreg_inter_estimations <- function(variable,+ ), |
||
| 296 | +43 |
- given,+ pct = TRUE) {
|
||
| 297 | -+ | |||
| 44 | +7x |
- lvl_var,+ checkmate::assert_character(arm_x, len = 1) |
||
| 298 | -+ | |||
| 45 | +7x |
- lvl_given,+ checkmate::assert_character(arm_y, min.len = 1) |
||
| 299 | -+ | |||
| 46 | +7x |
- mod,+ checkmate::assert_character(col_label, len = length(arm_y)) |
||
| 300 | +47 |
- conf_level = 0.95) {
+
|
||
| 301 | -16x | +48 | +7x |
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs) |
| 302 | -16x | +49 | +7x |
- giv_lvl <- paste0(given, lvl_given)+ for (i in seq_len(length(arm_y))) {
|
| 303 | -16x | +50 | +7x |
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ combodf <- rbind( |
| 304 | -16x | +51 | +7x |
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ combodf, |
| 305 | -16x | +52 | +7x |
- design_mat <- within(+ tibble::tribble( |
| 306 | -16x | +53 | +7x |
- data = design_mat,+ ~valname, ~label, ~levelcombo, ~exargs, |
| 307 | -16x | +54 | +7x |
- expr = {
+ paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
+ |
+
| 55 | ++ |
+ )+ |
+ ||
| 56 | ++ |
+ )+ |
+ ||
| 57 | ++ |
+ } |
||
| 308 | -16x | +58 | +7x |
- inter <- paste0(variable, ":", given)+ if (pct) combodf$valname <- paste0(combodf$valname, "_pct") |
| 309 | -16x | +59 | +7x |
- rev_inter <- paste0(given, ":", variable)+ add_combo_levels(combodf) |
| 310 | +60 |
- }+ } |
||
| 311 | +61 |
- )+ |
||
| 312 | -16x | +|||
| 62 | +
- split_by_variable <- design_mat$variable+ #' Analysis Function to Calculate Risk Difference Column Values |
|||
| 313 | -16x | +|||
| 63 | +
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ #' |
|||
| 314 | +64 |
-
+ #' In the risk difference column, this function uses the statistics function associated with `afun` to |
||
| 315 | -16x | +|||
| 65 | +
- mmat <- stats::model.matrix(mod)[1, ]+ #' 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 | ++ |
+ #' @param s_args (named `list`)\cr Additional arguments to be passed to the statistics function and analysis+ |
+ ||
| 75 | ++ |
+ #' function supplied in `afun`.+ |
+ ||
| 76 | ++ |
+ #'+ |
+ ||
| 77 | ++ |
+ #' @return A list of formatted [rtables::CellValue()].+ |
+ ||
| 78 | ++ |
+ #'+ |
+ ||
| 79 | ++ |
+ #' @seealso+ |
+ ||
| 80 | ++ |
+ #' * [stat_propdiff_ci()] for details on risk difference calculation.+ |
+ ||
| 81 | ++ |
+ #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with+ |
+ ||
| 82 | ++ |
+ #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column+ |
+ ||
| 83 | ++ |
+ #' to a table layout.+ |
+ ||
| 84 | ++ |
+ #'+ |
+ ||
| 85 | ++ |
+ #' @keywords internal+ |
+ ||
| 86 | ++ |
+ afun_riskdiff <- function(df,+ |
+ ||
| 87 | ++ |
+ labelstr = "",+ |
+ ||
| 88 | ++ |
+ .var,+ |
+ ||
| 89 | ++ |
+ .N_col, # nolint+ |
+ ||
| 90 | ++ |
+ .N_row, # nolint+ |
+ ||
| 91 | ++ |
+ .df_row,+ |
+ ||
| 92 | ++ |
+ .spl_context,+ |
+ ||
| 93 | ++ |
+ .all_col_counts,+ |
+ ||
| 94 | ++ |
+ .stats,+ |
+ ||
| 95 | ++ |
+ .formats = NULL,+ |
+ ||
| 96 | ++ |
+ .labels = NULL,+ |
+ ||
| 97 | ++ |
+ .indent_mods = NULL,+ |
+ ||
| 98 | ++ |
+ na_str = default_na_str(),+ |
+ ||
| 99 | ++ |
+ afun,+ |
+ ||
| 100 | ++ |
+ s_args = list()) {
|
||
| 316 | -16x | +101 | +44x |
- mmat[!mmat == 0] <- 0+ if (!any(grepl("riskdiff", names(.spl_context)))) {
+ |
+
| 102 | +! | +
+ stop(+ |
+ ||
| 103 | +! | +
+ "Please set up levels to use in risk difference calculations using the `add_riskdiff` ",+ |
+ ||
| 104 | +! | +
+ "split function within `split_cols_by`. See ?add_riskdiff for details." |
||
| 317 | +105 |
-
+ )+ |
+ ||
| 106 | ++ |
+ } |
||
| 318 | -16x | +107 | +44x |
- design_mat <- apply(+ checkmate::assert_list(afun, len = 1, types = "function") |
| 319 | -16x | +108 | +44x |
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ checkmate::assert_named(afun) |
| 320 | -46x | +109 | +44x |
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ afun_args <- list( |
| 321 | -46x | +110 | +44x |
- mmat+ .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr, |
| 322 | -+ | |||
| 111 | +44x |
- }+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
||
| 323 | +112 |
) |
||
| 324 | -16x | +113 | +44x |
- colnames(design_mat) <- interaction_names+ afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))]+ |
+
| 114 | +! | +
+ if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
|
||
| 325 | +115 | |||
| 326 | -16x | +116 | +44x |
- coef <- stats::coef(mod)+ cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1) |
| 327 | -16x | +117 | +44x |
- vcov <- stats::vcov(mod)+ if (!grepl("^riskdiff", cur_split)) {
+ |
+
| 118 | ++ |
+ # Apply basic afun (no risk difference) in all other columns |
||
| 328 | -16x | +119 | +33x |
- betas <- as.matrix(coef)+ do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args))+ |
+
| 120 | ++ |
+ } else {
|
||
| 329 | -16x | +121 | +11x |
- coef_hat <- t(design_mat) %*% betas+ arm_x <- strsplit(cur_split, "_")[[1]][2] |
| 330 | -16x | +122 | +11x |
- dimnames(coef_hat)[2] <- "coef"+ arm_y <- strsplit(cur_split, "_")[[1]][3] |
| 331 | -16x | +123 | +11x |
- coef_se <- apply(+ if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
+ |
+
| 124 | +! | +
+ arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
+ |
+ ||
| 125 | +! | +
+ arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
+ |
+ ||
| 126 | ++ |
+ } else {
|
||
| 332 | -16x | +127 | +11x |
- design_mat, 2,+ arm_spl_x <- arm_x |
| 333 | -16x | +128 | +11x |
- function(x) {
+ arm_spl_y <- arm_y+ |
+
| 129 | ++ |
+ } |
||
| 334 | -46x | +130 | +11x |
- vcov_el <- as.logical(x)+ N_col_x <- .all_col_counts[[arm_spl_x]] # nolint |
| 335 | -46x | +131 | +11x |
- y <- vcov[vcov_el, vcov_el]+ N_col_y <- .all_col_counts[[arm_spl_y]] # nolint |
| 336 | -46x | +132 | +11x |
- y <- sum(y)+ cur_var <- tail(.spl_context$cur_col_split[[1]], 1)+ |
+
| 133 | ++ | + + | +||
| 134 | ++ |
+ # Apply statistics function to arm X and arm Y data |
||
| 337 | -46x | +135 | +11x |
- y <- sqrt(y)+ s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))]) |
| 338 | -46x | +136 | +11x |
- return(y)+ s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args))+ |
+
| 137 | +11x | +
+ s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args)) |
||
| 339 | +138 |
- }+ |
||
| 340 | +139 |
- )+ # Get statistic name and row names |
||
| 341 | -16x | +140 | +11x |
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
|
| 342 | -16x | +141 | +11x |
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ if ("flag_variables" %in% names(s_args)) {
|
| 343 | -16x | +142 | +1x |
- y <- apply(y, 1, function(x) {
+ var_nms <- s_args$flag_variables |
| 344 | -46x | +143 | +10x |
- x["hr"] <- exp(x["coef"])+ } else if (!is.null(names(s_x[[stat]]))) {
|
| 345 | -46x | +144 | +4x |
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ var_nms <- names(s_x[[stat]])+ |
+
| 145 | ++ |
+ } else {
|
||
| 346 | -46x | +146 | +6x |
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ var_nms <- "" |
| 347 | -46x | +147 | +6x |
- x+ s_x[[stat]] <- list(s_x[[stat]])+ |
+
| 148 | +6x | +
+ s_y[[stat]] <- list(s_y[[stat]]) |
||
| 348 | +149 |
- })+ }+ |
+ ||
| 150 | ++ | + + | +||
| 151 | ++ |
+ # Calculate risk difference for each row, repeated if multiple statistics in table |
||
| 349 | -16x | +152 | +11x |
- y <- t(y)+ pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct" |
| 350 | -16x | +153 | +11x |
- y <- by(y, split_by_variable, identity)+ rd_ci <- rep(stat_propdiff_ci( |
| 351 | -16x | +154 | +11x |
- y <- lapply(y, as.matrix)+ lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1), |
| 352 | -16x | +155 | +11x |
- attr(y, "details") <- paste0(+ N_col_x, N_col_y, |
| 353 | -16x | +156 | +11x |
- "Estimations of ", variable,+ list_names = var_nms, |
| 354 | -16x | +157 | +11x |
- " hazard ratio given the level of ", given, " compared to ",+ pct = pct |
| 355 | -16x | +158 | +11x |
- variable, " level ", lvl_var[1], "."+ ), max(1, length(.stats))) |
| 356 | +159 |
- )+ |
||
| 357 | -16x | +160 | +11x |
- y+ in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods) |
| 358 | +161 | ++ |
+ }+ |
+ |
| 162 |
}@@ -27737,14 +28318,14 @@ tern coverage - 90.46% |
| 1 |
- #' Helper Functions for Tabulating Survival Duration by Subgroup+ #' Cox Regression Helper: Interactions |
|||
| 5 |
- #' Helper functions that tabulate in a data frame statistics such as median survival+ #' Test and estimate the effect of a treatment in interaction with a covariate. |
|||
| 6 |
- #' time and hazard ratio for population subgroups.+ #' 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 |
- #' @inheritParams argument_convention+ #' |
|||
| 9 |
- #' @inheritParams survival_coxph_pairwise+ #' @inheritParams argument_convention |
|||
| 10 |
- #' @inheritParams survival_duration_subgroups+ #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested. |
|||
| 11 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' @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 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' @param mod (`coxph`)\cr the Cox regression model. |
|||
| 14 |
- #'+ #' @param label (`string`)\cr the label to be returned as `term_label`. |
|||
| 15 |
- #' @examples+ #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()]. |
|||
| 16 |
- #' library(dplyr)+ #' @param ... see methods. |
|||
| 17 |
- #' library(forcats)+ #' |
|||
| 18 |
- #'+ #' @examples |
|||
| 19 |
- #' adtte <- tern_ex_adtte+ #' library(survival) |
|||
| 21 |
- #' # Save variable labels before data processing steps.+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 22 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' |
|||
| 23 |
- #'+ #' # Testing dataset [survival::bladder]. |
|||
| 24 |
- #' adtte_f <- adtte %>%+ #' dta_bladder <- with( |
|||
| 25 |
- #' filter(+ #' data = bladder[bladder$enum < 5, ], |
|||
| 26 |
- #' PARAMCD == "OS",+ #' data.frame( |
|||
| 27 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ #' time = stop, |
|||
| 28 |
- #' SEX %in% c("M", "F")
+ #' status = event, |
|||
| 29 |
- #' ) %>%+ #' armcd = as.factor(rx), |
|||
| 30 |
- #' mutate(+ #' covar1 = as.factor(enum), |
|||
| 31 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' covar2 = factor( |
|||
| 32 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ #' sample(as.factor(enum)), |
|||
| 33 |
- #' SEX = droplevels(SEX),+ #' levels = 1:4, |
|||
| 34 |
- #' is_event = CNSR == 0+ #' labels = c("F", "F", "M", "M")
|
|||
| 35 |
- #' )+ #' ) |
|||
| 36 |
- #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
+ #' ) |
|||
| 37 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' ) |
|||
| 38 |
- #'+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
|||
| 39 |
- #' @name h_survival_duration_subgroups+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
|||
| 40 |
- NULL+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|||
| 41 |
-
+ #' |
|||
| 42 |
- #' @describeIn h_survival_duration_subgroups helper to prepare a data frame of median survival times by arm.+ #' plot( |
|||
| 43 |
- #'+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
|||
| 44 |
- #' @return+ #' lty = 2:4, |
|||
| 45 |
- #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`.+ #' xlab = "Months", |
|||
| 46 |
- #'+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
|||
| 47 |
- #' @examples+ #' ) |
|||
| 48 |
- #' # Extract median survival time for one group.+ #' |
|||
| 49 |
- #' h_survtime_df(+ #' @name cox_regression_inter |
|||
| 50 |
- #' tte = adtte_f$AVAL,+ NULL |
|||
| 51 |
- #' is_event = adtte_f$is_event,+ |
|||
| 52 |
- #' arm = adtte_f$ARM+ #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect. |
|||
| 53 |
- #' )+ #' |
|||
| 54 |
- #'+ #' @return |
|||
| 55 |
- #' @export+ #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following |
|||
| 56 |
- h_survtime_df <- function(tte, is_event, arm) {
+ #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`. |
|||
| 57 | -61x | +
- checkmate::assert_numeric(tte)+ #' |
||
| 58 | -60x | +
- checkmate::assert_logical(is_event, len = length(tte))+ #' @export |
||
| 59 | -60x | +
- assert_valid_factor(arm, len = length(tte))+ h_coxreg_inter_effect <- function(x, |
||
| 60 |
-
+ effect, |
|||
| 61 | -60x | +
- df_tte <- data.frame(+ covar, |
||
| 62 | -60x | +
- tte = tte,+ mod, |
||
| 63 | -60x | +
- is_event = is_event,+ label, |
||
| 64 | -60x | +
- stringsAsFactors = FALSE+ control, |
||
| 65 |
- )+ ...) {
|
|||
| 66 | -+ | 26x |
-
+ UseMethod("h_coxreg_inter_effect", x)
|
|
| 67 |
- # Delete NAs+ } |
|||
| 68 | -60x | +
- non_missing_rows <- stats::complete.cases(df_tte)+ |
||
| 69 | -60x | +
- df_tte <- df_tte[non_missing_rows, ]+ #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate. |
||
| 70 | -60x | +
- arm <- arm[non_missing_rows]+ #' |
||
| 71 |
-
+ #' @method h_coxreg_inter_effect numeric |
|||
| 72 | -60x | +
- lst_tte <- split(df_tte, arm)+ #' |
||
| 73 | -60x | +
- lst_results <- Map(function(x, arm) {
+ #' @param at (`list`)\cr a list with items named after the covariate, every |
||
| 74 | -120x | +
- if (nrow(x) > 0) {
+ #' item is a vector of levels at which the interaction should be estimated. |
||
| 75 | -116x | +
- s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event")+ #' |
||
| 76 | -116x | +
- median_est <- unname(as.numeric(s_surv$median))+ #' @export |
||
| 77 | -116x | +
- n_events <- sum(x$is_event)+ h_coxreg_inter_effect.numeric <- function(x, |
||
| 78 |
- } else {
+ effect, |
|||
| 79 | -4x | +
- median_est <- NA+ covar, |
||
| 80 | -4x | +
- n_events <- NA+ mod, |
||
| 81 |
- }+ label, |
|||
| 82 |
-
+ control, |
|||
| 83 | -120x | +
- data.frame(+ at, |
||
| 84 | -120x | +
- arm = arm,+ ...) {
|
||
| 85 | -120x | +7x |
- n = nrow(x),+ betas <- stats::coef(mod) |
|
| 86 | -120x | +7x |
- n_events = n_events,+ attrs <- attr(stats::terms(mod), "term.labels") |
|
| 87 | -120x | +7x |
- median = median_est,+ term_indices <- grep( |
|
| 88 | -120x | +7x |
- stringsAsFactors = FALSE+ pattern = effect, |
|
| 89 | -+ | 7x |
- )+ x = attrs[!grepl("strata\\(", attrs)]
|
|
| 90 | -60x | +
- }, lst_tte, names(lst_tte))+ ) |
||
| 91 | -+ | 7x |
-
+ checkmate::assert_vector(term_indices, len = 2) |
|
| 92 | -60x | +7x |
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ betas <- betas[term_indices] |
|
| 93 | -60x | +7x |
- df$arm <- factor(df$arm, levels = levels(arm))+ betas_var <- diag(stats::vcov(mod))[term_indices] |
|
| 94 | -60x | +7x |
- df+ 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 |
- #' @describeIn h_survival_duration_subgroups summarizes median survival times by arm and across subgroups+ } else {
|
|||
| 98 | -+ | 1x |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ at[[covar]] |
|
| 99 |
- #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ } |
|||
| 100 | -+ | 7x |
- #' groupings for `subgroups` variables.+ effect_index <- !grepl(covar, names(betas)) |
|
| 101 | -+ | 7x |
- #'+ coef_hat <- betas[effect_index] + xval * betas[!effect_index] |
|
| 102 | -+ | 7x |
- #' @return+ coef_se <- sqrt( |
|
| 103 | -+ | 7x |
- #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`,+ betas_var[effect_index] + |
|
| 104 | -+ | 7x |
- #' `var`, `var_label`, and `row_type`.+ xval ^ 2 * betas_var[!effect_index] + # styler: off |
|
| 105 | -+ | 7x |
- #'+ 2 * xval * betas_cov |
|
| 106 |
- #' @examples+ ) |
|||
| 107 | -+ | 7x |
- #' # Extract median survival time for multiple groups.+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
|
| 108 | -+ | 7x |
- #' h_survtime_subgroups_df(+ data.frame( |
|
| 109 | -+ | 7x |
- #' variables = list(+ effect = "Covariate:", |
|
| 110 | -+ | 7x |
- #' tte = "AVAL",+ term = rep(covar, length(xval)), |
|
| 111 | -+ | 7x |
- #' is_event = "is_event",+ term_label = paste0(" ", xval),
|
|
| 112 | -+ | 7x |
- #' arm = "ARM",+ level = as.character(xval), |
|
| 113 | -+ | 7x |
- #' subgroups = c("SEX", "BMRKR2")
+ n = NA, |
|
| 114 | -+ | 7x |
- #' ),+ hr = exp(coef_hat), |
|
| 115 | -+ | 7x |
- #' data = adtte_f+ lcl = exp(coef_hat - q_norm * coef_se), |
|
| 116 | -+ | 7x |
- #' )+ ucl = exp(coef_hat + q_norm * coef_se), |
|
| 117 | -+ | 7x |
- #'+ pval = NA, |
|
| 118 | -+ | 7x |
- #' # Define groupings for BMRKR2 levels.+ pval_inter = NA, |
|
| 119 | -+ | 7x |
- #' h_survtime_subgroups_df(+ stringsAsFactors = FALSE |
|
| 120 |
- #' variables = list(+ ) |
|||
| 121 |
- #' tte = "AVAL",+ } |
|||
| 122 |
- #' is_event = "is_event",+ |
|||
| 123 |
- #' arm = "ARM",+ #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate. |
|||
| 124 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' |
|||
| 125 |
- #' ),+ #' @method h_coxreg_inter_effect factor |
|||
| 126 |
- #' data = adtte_f,+ #' |
|||
| 127 |
- #' groups_lists = list(+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
|||
| 128 |
- #' BMRKR2 = list(+ #' |
|||
| 129 |
- #' "low" = "LOW",+ #' @export |
|||
| 130 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ h_coxreg_inter_effect.factor <- function(x, |
|||
| 131 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ effect, |
|||
| 132 |
- #' )+ covar, |
|||
| 133 |
- #' )+ mod, |
|||
| 134 |
- #' )+ label, |
|||
| 135 |
- #'+ control, |
|||
| 136 |
- #' @export+ data, |
|||
| 137 |
- h_survtime_subgroups_df <- function(variables,+ ...) {
|
|||
| 138 | -+ | 15x |
- data,+ lvl_given <- levels(x) |
|
| 139 | -+ | 15x |
- groups_lists = list(),+ y <- h_coxreg_inter_estimations( |
|
| 140 | -+ | 15x |
- label_all = "All Patients") {
+ variable = effect, given = covar, |
|
| 141 | -12x | +15x |
- checkmate::assert_character(variables$tte)+ lvl_var = levels(data[[effect]]), |
|
| 142 | -12x | +15x |
- checkmate::assert_character(variables$is_event)+ lvl_given = lvl_given, |
|
| 143 | -12x | +15x |
- checkmate::assert_character(variables$arm)+ mod = mod, |
|
| 144 | -12x | +15x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ conf_level = 0.95 |
|
| 145 | -+ | 15x |
-
+ )[[1]] |
|
| 146 | -12x | +
- assert_df_with_variables(data, variables)+ |
||
| 147 | -+ | 15x |
-
+ data.frame( |
|
| 148 | -12x | +15x |
- checkmate::assert_string(label_all)+ effect = "Covariate:", |
|
| 149 | -+ | 15x |
-
+ term = rep(covar, nrow(y)), |
|
| 150 | -+ | 15x |
- # Add All Patients.+ term_label = paste0(" ", lvl_given),
|
|
| 151 | -12x | +15x |
- result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]])+ level = lvl_given, |
|
| 152 | -12x | +15x |
- result_all$subgroup <- label_all+ n = NA, |
|
| 153 | -12x | +15x |
- result_all$var <- "ALL"+ hr = y[, "hr"], |
|
| 154 | -12x | +15x |
- result_all$var_label <- label_all+ lcl = y[, "lcl"], |
|
| 155 | -12x | +15x |
- result_all$row_type <- "content"+ ucl = y[, "ucl"], |
|
| 156 | -+ | 15x |
-
+ pval = NA, |
|
| 157 | -+ | 15x |
- # Add Subgroups.+ pval_inter = NA, |
|
| 158 | -12x | +15x |
- if (is.null(variables$subgroups)) {
+ stringsAsFactors = FALSE |
|
| 159 | -3x | +
- result_all+ ) |
||
| 160 |
- } else {
+ } |
|||
| 161 | -9x | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
||
| 162 | -9x | +
- l_result <- lapply(l_data, function(grp) {
+ #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate. |
||
| 163 | -45x | +
- result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]])+ #' This makes an automatic conversion to `factor` and then forwards to the method for factors. |
||
| 164 | -45x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ #' |
||
| 165 | -45x | +
- cbind(result, result_labels)+ #' @method h_coxreg_inter_effect character |
||
| 166 |
- })+ #' |
|||
| 167 | -9x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' @note |
||
| 168 | -9x | +
- result_subgroups$row_type <- "analysis"+ #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is |
||
| 169 | -9x | +
- rbind(+ #' therefore better to always pre-process the dataset such that factors are manually created from character |
||
| 170 | -9x | +
- result_all,+ #' variables before passing the dataset to [rtables::build_table()]. |
||
| 171 | -9x | +
- result_subgroups+ #' |
||
| 172 |
- )+ #' @export |
|||
| 173 |
- }+ h_coxreg_inter_effect.character <- function(x, |
|||
| 174 |
- }+ effect, |
|||
| 175 |
-
+ covar, |
|||
| 176 |
- #' @describeIn h_survival_duration_subgroups helper to prepare a data frame with estimates of+ mod, |
|||
| 177 |
- #' treatment hazard ratio.+ label, |
|||
| 178 |
- #'+ control, |
|||
| 179 |
- #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.+ data, |
|||
| 180 |
- #'+ ...) {
|
|||
| 181 | -+ | 4x |
- #' @return+ y <- as.factor(x) |
|
| 182 |
- #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`,+ |
|||
| 183 | -+ | 4x |
- #' `conf_level`, `pval` and `pval_label`.+ h_coxreg_inter_effect( |
|
| 184 | -+ | 4x |
- #'+ x = y, |
|
| 185 | -+ | 4x |
- #' @examples+ effect = effect, |
|
| 186 | -+ | 4x |
- #' # Extract hazard ratio for one group.+ covar = covar, |
|
| 187 | -+ | 4x |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM)+ mod = mod, |
|
| 188 | -+ | 4x |
- #'+ label = label, |
|
| 189 | -+ | 4x |
- #' # Extract hazard ratio for one group with stratification factor.+ control = control, |
|
| 190 | -+ | 4x |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1)+ data = data, |
|
| 191 |
- #'+ ... |
|||
| 192 |
- #' @export+ ) |
|||
| 193 |
- h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
+ } |
|||
| 194 | -64x | +
- checkmate::assert_numeric(tte)+ |
||
| 195 | -64x | +
- checkmate::assert_logical(is_event, len = length(tte))+ #' @describeIn cox_regression_inter A higher level function to get |
||
| 196 | -64x | +
- assert_valid_factor(arm, n.levels = 2, len = length(tte))+ #' the results of the interaction test and the estimated values. |
||
| 197 |
-
+ #' |
|||
| 198 | -64x | +
- df_tte <- data.frame(tte = tte, is_event = is_event)+ #' @return |
||
| 199 | -64x | +
- strata_vars <- NULL+ #' * `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 | -64x | +
- if (!is.null(strata_data)) {
+ #' |
||
| 202 | -5x | +
- if (is.data.frame(strata_data)) {
+ #' @examples |
||
| 203 | -4x | +
- strata_vars <- names(strata_data)+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
||
| 204 | -4x | +
- checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))+ #' h_coxreg_extract_interaction( |
||
| 205 | -4x | +
- assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars)))+ #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder, |
||
| 206 |
- } else {
+ #' control = control_coxreg() |
|||
| 207 | -1x | +
- assert_valid_factor(strata_data, len = nrow(df_tte))+ #' ) |
||
| 208 | -1x | +
- strata_vars <- "strata_data"+ #' |
||
| 209 |
- }+ #' @export |
|||
| 210 | -5x | +
- df_tte[strata_vars] <- strata_data+ h_coxreg_extract_interaction <- function(effect, |
||
| 211 |
- }+ covar, |
|||
| 212 |
-
+ mod, |
|||
| 213 | -64x | +
- l_df <- split(df_tte, arm)+ data, |
||
| 214 |
-
+ at, |
|||
| 215 | -64x | +
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ control) {
|
||
| 216 | -+ | 27x |
- # Hazard ratio and CI.+ if (!any(attr(stats::terms(mod), "order") == 2)) {
|
|
| 217 | -60x | +10x |
- result <- s_coxph_pairwise(+ y <- h_coxreg_univar_extract( |
|
| 218 | -60x | +10x |
- df = l_df[[2]],+ effect = effect, covar = covar, mod = mod, data = data, control = control |
|
| 219 | -60x | +
- .ref_group = l_df[[1]],+ ) |
||
| 220 | -60x | +10x |
- .in_ref_col = FALSE,+ y$pval_inter <- NA |
|
| 221 | -60x | +10x |
- .var = "tte",+ y |
|
| 222 | -60x | +
- is_event = "is_event",+ } else {
|
||
| 223 | -60x | +17x |
- strat = strata_vars,+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
|
| 224 | -60x | +
- control = control+ |
||
| 225 |
- )+ # Test the main treatment effect. |
|||
| 226 | -+ | 17x |
-
+ mod_aov <- muffled_car_anova(mod, test_statistic) |
|
| 227 | -60x | +17x |
- df <- data.frame(+ sum_anova <- broom::tidy(mod_aov) |
|
| 228 | -+ | 17x |
- # Dummy column needed downstream to create a nested header.+ pval <- sum_anova[sum_anova$term == effect, ][["p.value"]] |
|
| 229 | -60x | +
- arm = " ",+ |
||
| 230 | -60x | +
- n_tot = unname(as.numeric(result$n_tot)),+ # Test the interaction effect. |
||
| 231 | -60x | +17x |
- n_tot_events = unname(as.numeric(result$n_tot_events)),+ pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
|
|
| 232 | -60x | +17x |
- hr = unname(as.numeric(result$hr)),+ covar_test <- data.frame( |
|
| 233 | -60x | +17x |
- lcl = unname(result$hr_ci[1]),+ effect = "Covariate:", |
|
| 234 | -60x | +17x |
- ucl = unname(result$hr_ci[2]),+ term = covar, |
|
| 235 | -60x | +17x |
- conf_level = control[["conf_level"]],+ term_label = unname(labels_or_names(data[covar])), |
|
| 236 | -60x | +17x |
- pval = as.numeric(result$pvalue),+ level = "", |
|
| 237 | -60x | +17x |
- pval_label = obj_label(result$pvalue),+ n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval, |
|
| 238 | -60x | +17x |
- stringsAsFactors = FALSE+ pval_inter = pval_inter, |
|
| 239 | -+ | 17x |
- )+ stringsAsFactors = FALSE |
|
| 240 |
- } else if (+ ) |
|||
| 241 | -4x | +
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ # Estimate the interaction. |
||
| 242 | -4x | +17x |
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ y <- h_coxreg_inter_effect( |
|
| 243 | -+ | 17x |
- ) {
+ data[[covar]], |
|
| 244 | -4x | +17x |
- df_tte_complete <- df_tte[stats::complete.cases(df_tte), ]+ covar = covar, |
|
| 245 | -4x | +17x |
- df <- data.frame(+ effect = effect, |
|
| 246 | -+ | 17x |
- # Dummy column needed downstream to create a nested header.+ mod = mod, |
|
| 247 | -4x | +17x |
- arm = " ",+ label = unname(labels_or_names(data[covar])), |
|
| 248 | -4x | +17x |
- n_tot = nrow(df_tte_complete),+ at = at, |
|
| 249 | -4x | +17x |
- n_tot_events = sum(df_tte_complete$is_event),+ control = control, |
|
| 250 | -4x | +17x |
- hr = NA,+ data = data |
|
| 251 | -4x | +
- lcl = NA,+ ) |
||
| 252 | -4x | +17x |
- ucl = NA,+ rbind(covar_test, y) |
|
| 253 | -4x | +
- conf_level = control[["conf_level"]],+ } |
||
| 254 | -4x | +
- pval = NA,+ } |
||
| 255 | -4x | +
- pval_label = NA,+ |
||
| 256 | -4x | +
- stringsAsFactors = FALSE+ #' @describeIn cox_regression_inter Hazard ratio estimation in interactions. |
||
| 257 |
- )+ #' |
|||
| 258 |
- } else {
+ #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation |
|||
| 259 | -! | +
- df <- data.frame(+ #' of the levels of `variable` given the levels of `given`. |
||
| 260 |
- # Dummy column needed downstream to create a nested header.+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels has given by [levels()]. |
|||
| 261 | -! | +
- arm = " ",+ #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]). |
||
| 262 | -! | +
- n_tot = 0L,+ #' |
||
| 263 | -! | +
- n_tot_events = 0L,+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
||
| 264 | -! | +
- hr = NA,+ #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex. |
||
| 265 | -! | +
- lcl = NA,+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 266 | -! | +
- ucl = NA,+ #' |
||
| 267 | -! | +
- conf_level = control[["conf_level"]],+ #' - b1 (arm b), b2 (arm c) |
||
| 268 | -! | +
- pval = NA,+ #' - b3 (sex m) |
||
| 269 | -! | +
- pval_label = NA,+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 270 | -! | +
- stringsAsFactors = FALSE+ #' |
||
| 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 | -64x | +
- df+ #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$. |
||
| 275 |
- }+ #' |
|||
| 276 |
-
+ #' @return |
|||
| 277 |
- #' @describeIn h_survival_duration_subgroups summarizes estimates of the treatment hazard ratio+ #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding |
|||
| 278 |
- #' across subgroups in a data frame. `variables` corresponds to the names of variables found in+ #' to the combinations of `variable` and `given`, with columns: |
|||
| 279 |
- #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and+ #' * `coef_hat`: Estimation of the coefficient. |
|||
| 280 |
- #' optionally `subgroups` and `strat`. `groups_lists` optionally specifies+ #' * `coef_se`: Standard error of the estimation. |
|||
| 281 |
- #' groupings for `subgroups` variables.+ #' * `hr`: Hazard ratio. |
|||
| 282 |
- #'+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
|||
| 283 |
- #' @return+ #' |
|||
| 284 |
- #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`,+ #' @examples |
|||
| 285 |
- #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
|||
| 286 |
- #'+ #' result <- h_coxreg_inter_estimations( |
|||
| 287 |
- #' @examples+ #' variable = "armcd", given = "covar1", |
|||
| 288 |
- #' # Extract hazard ratio for multiple groups.+ #' lvl_var = levels(dta_bladder$armcd), |
|||
| 289 |
- #' h_coxph_subgroups_df(+ #' lvl_given = levels(dta_bladder$covar1), |
|||
| 290 |
- #' variables = list(+ #' mod = mod, conf_level = .95 |
|||
| 291 |
- #' tte = "AVAL",+ #' ) |
|||
| 292 |
- #' is_event = "is_event",+ #' result |
|||
| 293 |
- #' arm = "ARM",+ #' |
|||
| 294 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' @export |
|||
| 295 |
- #' ),+ h_coxreg_inter_estimations <- function(variable, |
|||
| 296 |
- #' data = adtte_f+ given, |
|||
| 297 |
- #' )+ lvl_var, |
|||
| 298 |
- #'+ lvl_given, |
|||
| 299 |
- #' # Define groupings of BMRKR2 levels.+ mod, |
|||
| 300 |
- #' h_coxph_subgroups_df(+ conf_level = 0.95) {
|
|||
| 301 | -+ | 16x |
- #' variables = list(+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
|
| 302 | -+ | 16x |
- #' tte = "AVAL",+ giv_lvl <- paste0(given, lvl_given) |
|
| 303 | -+ | 16x |
- #' is_event = "is_event",+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
|
| 304 | -+ | 16x |
- #' arm = "ARM",+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
|
| 305 | -+ | 16x |
- #' subgroups = c("SEX", "BMRKR2")
+ design_mat <- within( |
|
| 306 | -+ | 16x |
- #' ),+ data = design_mat, |
|
| 307 | -+ | 16x |
- #' data = adtte_f,+ expr = {
|
|
| 308 | -+ | 16x |
- #' groups_lists = list(+ inter <- paste0(variable, ":", given) |
|
| 309 | -+ | 16x |
- #' BMRKR2 = list(+ rev_inter <- paste0(given, ":", variable) |
|
| 310 |
- #' "low" = "LOW",+ } |
|||
| 311 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ ) |
|||
| 312 | -+ | 16x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ split_by_variable <- design_mat$variable |
|
| 313 | -+ | 16x |
- #' )+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
|
| 314 |
- #' )+ |
|||
| 315 | -+ | 16x |
- #' )+ mmat <- stats::model.matrix(mod)[1, ] |
|
| 316 | -+ | 16x |
- #'+ mmat[!mmat == 0] <- 0 |
|
| 317 |
- #' # Extract hazard ratio for multiple groups with stratification factors.+ |
|||
| 318 | -+ | 16x |
- #' h_coxph_subgroups_df(+ design_mat <- apply( |
|
| 319 | -+ | 16x |
- #' variables = list(+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
|
| 320 | -+ | 46x |
- #' tte = "AVAL",+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
|
| 321 | -+ | 46x |
- #' is_event = "is_event",+ mmat |
|
| 322 |
- #' arm = "ARM",+ } |
|||
| 323 |
- #' subgroups = c("SEX", "BMRKR2"),
+ ) |
|||
| 324 | -+ | 16x |
- #' strat = c("STRATA1", "STRATA2")
+ colnames(design_mat) <- interaction_names |
|
| 325 |
- #' ),+ |
|||
| 326 | -+ | 16x |
- #' data = adtte_f+ coef <- stats::coef(mod) |
|
| 327 | -+ | 16x |
- #' )+ vcov <- stats::vcov(mod) |
|
| 328 | -+ | 16x |
- #'+ betas <- as.matrix(coef) |
|
| 329 | -+ | 16x |
- #' @export+ coef_hat <- t(design_mat) %*% betas |
|
| 330 | -+ | 16x |
- h_coxph_subgroups_df <- function(variables,+ dimnames(coef_hat)[2] <- "coef" |
|
| 331 | -+ | 16x |
- data,+ coef_se <- apply( |
|
| 332 | -+ | 16x |
- groups_lists = list(),+ design_mat, 2, |
|
| 333 | -+ | 16x |
- control = control_coxph(),+ function(x) {
|
|
| 334 | -+ | 46x |
- label_all = "All Patients") {
+ vcov_el <- as.logical(x) |
|
| 335 | -13x | +46x |
- checkmate::assert_character(variables$tte)+ y <- vcov[vcov_el, vcov_el] |
|
| 336 | -13x | +46x |
- checkmate::assert_character(variables$is_event)+ y <- sum(y) |
|
| 337 | -13x | +46x |
- checkmate::assert_character(variables$arm)+ y <- sqrt(y) |
|
| 338 | -13x | +46x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ return(y) |
|
| 339 | -13x | +
- checkmate::assert_character(variables$strat, null.ok = TRUE)+ } |
||
| 340 | -13x | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ ) |
||
| 341 | -13x | +16x |
- assert_df_with_variables(data, variables)+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
|
| 342 | -13x | +16x |
- checkmate::assert_string(label_all)+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
|
| 343 | -+ | 16x |
-
+ y <- apply(y, 1, function(x) {
|
|
| 344 | -+ | 46x |
- # Add All Patients.+ x["hr"] <- exp(x["coef"]) |
|
| 345 | -13x | +46x |
- result_all <- h_coxph_df(+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
|
| 346 | -13x | +46x |
- tte = data[[variables$tte]],+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
|
| 347 | -13x | +46x |
- is_event = data[[variables$is_event]],+ x |
|
| 348 | -13x | +
- arm = data[[variables$arm]],+ }) |
||
| 349 | -13x | +16x |
- strata_data = if (is.null(variables$strat)) NULL else data[variables$strat],+ y <- t(y) |
|
| 350 | -13x | +16x |
- control = control+ y <- by(y, split_by_variable, identity) |
|
| 351 | -+ | 16x |
- )+ y <- lapply(y, as.matrix) |
|
| 352 | -13x | +16x |
- result_all$subgroup <- label_all+ attr(y, "details") <- paste0( |
|
| 353 | -13x | +16x |
- result_all$var <- "ALL"+ "Estimations of ", variable, |
|
| 354 | -13x | +16x |
- result_all$var_label <- label_all+ " hazard ratio given the level of ", given, " compared to ", |
|
| 355 | -13x | +16x |
- result_all$row_type <- "content"+ variable, " level ", lvl_var[1], "." |
|
| 356 | - - | -|||
| 357 | -- |
- # Add Subgroups.- |
- ||
| 358 | -13x | -
- if (is.null(variables$subgroups)) {
- |
- ||
| 359 | -3x | -
- result_all- |
- ||
| 360 | -- |
- } else {
- |
- ||
| 361 | -10x | -
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)- |
- ||
| 362 | -- | - - | -||
| 363 | -10x | -
- l_result <- lapply(l_data, function(grp) {
- |
- ||
| 364 | -47x | -
- result <- h_coxph_df(- |
- ||
| 365 | -47x | -
- tte = grp$df[[variables$tte]],- |
- ||
| 366 | -47x | -
- is_event = grp$df[[variables$is_event]],- |
- ||
| 367 | -47x | -
- arm = grp$df[[variables$arm]],- |
- ||
| 368 | -47x | -
- strata_data = if (is.null(variables$strat)) NULL else grp$df[variables$strat],- |
- ||
| 369 | -47x | -
- control = control- |
- ||
| 370 | -- |
- )- |
- ||
| 371 | -47x | -
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]- |
- ||
| 372 | -47x | -
- cbind(result, result_labels)- |
- ||
| 373 | -- |
- })- |
- ||
| 374 | -- | - - | -||
| 375 | -10x | -
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))- |
- ||
| 376 | -10x | -
- result_subgroups$row_type <- "analysis"- |
- ||
| 377 | -- | - - | -||
| 378 | -10x | -
- rbind(- |
- ||
| 379 | -10x | -
- result_all,- |
- ||
| 380 | -10x | -
- result_subgroups- |
- ||
| 381 | -- |
- )- |
- ||
| 382 | -- |
- }- |
- ||
| 383 | -- |
- }- |
- ||
| 384 | -- | - - | -||
| 385 | -- |
- #' Split Dataframe by Subgroups- |
- ||
| 386 | -- |
- #'- |
- ||
| 387 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 388 | -- |
- #'- |
- ||
| 389 | -- |
- #' Split a dataframe into a non-nested list of subsets.- |
- ||
| 390 | -- |
- #'- |
- ||
| 391 | -- |
- #' @inheritParams argument_convention- |
- ||
| 392 | -- |
- #' @inheritParams survival_duration_subgroups- |
- ||
| 393 | -- |
- #' @param data (`data.frame`)\cr dataset to split.- |
- ||
| 394 | -- |
- #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets.- |
- ||
| 395 | -- |
- #' Unused levels not present in `data` are dropped. Note that the order in this vector- |
- ||
| 396 | -- |
- #' determines the order in the downstream table.- |
- ||
| 397 | -- |
- #'- |
- ||
| 398 | -- |
- #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`).- |
- ||
| 399 | -- |
- #'- |
- ||
| 400 | -- |
- #' @details Main functionality is to prepare data for use in forest plot layouts.- |
- ||
| 401 | -- |
- #'- |
- ||
| 402 | -- |
- #' @examples- |
- ||
| 403 | -- |
- #' df <- data.frame(- |
- ||
| 404 | -- |
- #' x = c(1:5),- |
- ||
| 405 | -- |
- #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
- |
- ||
| 406 | -- |
- #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
- |
- ||
| 407 | -- |
- #' )- |
- ||
| 408 | -- |
- #' formatters::var_labels(df) <- paste("label for", names(df))
- |
- ||
| 409 | -- |
- #'- |
- ||
| 410 | -- |
- #' h_split_by_subgroups(- |
- ||
| 411 | -- |
- #' data = df,- |
- ||
| 412 | -- |
- #' subgroups = c("y", "z")
- |
- ||
| 413 | -- |
- #' )- |
- ||
| 414 | -- |
- #'- |
- ||
| 415 | -- |
- #' h_split_by_subgroups(- |
- ||
| 416 | -- |
- #' data = df,- |
- ||
| 417 | -- |
- #' subgroups = c("y", "z"),
- |
- ||
| 418 | -- |
- #' groups_lists = list(- |
- ||
| 419 | -- |
- #' y = list("AB" = c("A", "B"), "C" = "C")
- |
- ||
| 420 | -- |
- #' )- |
- ||
| 421 | -- |
- #' )- |
- ||
| 422 | -- |
- #'- |
- ||
| 423 | -- |
- #' @export- |
- ||
| 424 | -- |
- h_split_by_subgroups <- function(data,- |
- ||
| 425 | -- |
- subgroups,- |
- ||
| 426 | -- |
- groups_lists = list()) {
- |
- ||
| 427 | -52x | -
- checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)- |
- ||
| 428 | -52x | -
- checkmate::assert_list(groups_lists, names = "named")- |
- ||
| 429 | -52x | -
- checkmate::assert_subset(names(groups_lists), subgroups)- |
- ||
| 430 | -52x | -
- assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))- |
- ||
| 431 | -- | - - | -||
| 432 | -52x | -
- data_labels <- unname(formatters::var_labels(data))- |
- ||
| 433 | -52x | -
- df_subgroups <- data[, subgroups, drop = FALSE]- |
- ||
| 434 | -52x | -
- subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)- |
- ||
| 435 | -- | - - | -||
| 436 | -52x | -
- l_labels <- Map(function(grp_i, name_i) {
- |
- ||
| 437 | -93x | -
- existing_levels <- levels(droplevels(grp_i))- |
- ||
| 438 | -93x | -
- grp_levels <- if (name_i %in% names(groups_lists)) {
- |
- ||
| 439 | -- |
- # For this variable groupings are defined. We check which groups are contained in the data.- |
- ||
| 440 | -11x | -
- group_list_i <- groups_lists[[name_i]]- |
- ||
| 441 | -11x | -
- group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)- |
- ||
| 442 | -11x | -
- names(which(group_has_levels))- |
- ||
| 443 | -- |
- } else {
- |
- ||
| 444 | -82x | -
- existing_levels- |
- ||
| 445 | -- |
- }- |
- ||
| 446 | -93x | -
- df_labels <- data.frame(- |
- ||
| 447 | -93x | -
- subgroup = grp_levels,- |
- ||
| 448 | -93x | -
- var = name_i,- |
- ||
| 449 | -93x | -
- var_label = unname(subgroup_labels[name_i]),- |
- ||
| 450 | -93x | -
- stringsAsFactors = FALSE # Rationale is that subgroups may not be unique.- |
- ||
| 451 | -- |
- )- |
- ||
| 452 | -52x | -
- }, df_subgroups, names(df_subgroups))- |
- ||
| 453 | -- | - - | -||
| 454 | -- |
- # Create a dataframe with one row per subgroup.- |
- ||
| 455 | -52x | -
- df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))- |
- ||
| 456 | -52x | -
- row_label <- paste0(df_labels$var, ".", df_labels$subgroup)- |
- ||
| 457 | -52x | -
- row_split_var <- factor(row_label, levels = row_label)- |
- ||
| 458 | -- | - - | -||
| 459 | -- |
- # Create a list of data subsets.- |
- ||
| 460 | -52x | -
- lapply(split(df_labels, row_split_var), function(row_i) {
- |
- ||
| 461 | -233x | -
- which_row <- if (row_i$var %in% names(groups_lists)) {
- |
- ||
| 462 | -31x | -
- data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]- |
- ||
| 463 | -- |
- } else {
- |
- ||
| 464 | -202x | -
- data[[row_i$var]] == row_i$subgroup- |
- ||
| 465 | -- |
- }- |
- ||
| 466 | -233x | -
- df <- data[which_row, ]- |
- ||
| 467 | -233x | -
- rownames(df) <- NULL- |
- ||
| 468 | -233x | -
- formatters::var_labels(df) <- data_labels- |
- ||
| 469 | -- | - - | -||
| 470 | -233x | -
- list(- |
- ||
| 471 | -233x | -
- df = df,+ ) |
||
| 472 | -233x | -
- df_labels = data.frame(row_i, row.names = NULL)- |
- ||
| 473 | -- |
- )- |
- ||
| 474 | -+ | 357 | +16x |
- })+ y |
| 475 | +358 |
}@@ -34497,28 +34259,28 @@ tern coverage - 90.46% |
| 1 |
- # Utility functions to cooperate with {rtables} package
+ #' Kaplan-Meier Plot |
||
| 2 |
-
+ #' |
||
| 3 |
- #' Convert Table into Matrix of Strings+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' @description `r lifecycle::badge("stable")`
+ #' 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 |
- #' Helper function to use mostly within tests. `with_spaces`parameter allows+ #' per group. |
||
| 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+ #' @inheritParams grid::gTree |
||
| 10 |
- #' formatted text that needs only to be copied and pasted in the expected output.+ #' @inheritParams argument_convention |
||
| 11 |
- #'+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
||
| 12 |
- #' @inheritParams formatters::toString+ #' @param variables (named `list`)\cr variable names. Details are: |
||
| 13 |
- #' @param x `rtables` table.+ #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values. |
||
| 14 |
- #' @param with_spaces (`logical`)\cr should the tested table keep the indentation and other relevant spaces?+ #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored. |
||
| 15 |
- #' @param print_txt_to_copy (`logical`)\cr utility to have a way to copy the input table directly+ #' * `arm` (`factor`)\cr the treatment group variable. |
||
| 16 |
- #' into the expected variable instead of copying it too manually.+ #' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors. |
||
| 17 |
- #'+ #' @param control_surv (`list`)\cr parameters for comparison details, specified by using |
||
| 18 |
- #' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the+ #' the helper function [control_surv_timepoint()]. Some possible parameter options are: |
||
| 19 |
- #' table will be printed to console, ready to be copied as a expected value.+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
||
| 20 |
- #'+ #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type, |
||
| 21 |
- #' @examples+ #' see more in [survival::survfit()]. Note that the option "none" is no longer supported. |
||
| 22 |
- #' tbl <- basic_table() %>%+ #' @param xticks (`numeric`, `number`, or `NULL`)\cr numeric vector of ticks or single number with spacing |
||
| 23 |
- #' split_rows_by("SEX") %>%
+ #' between ticks on the x axis. If `NULL` (default), [labeling::extended()] is used to determine |
||
| 24 |
- #' split_cols_by("ARM") %>%
+ #' an optimal tick position on the x axis. |
||
| 25 |
- #' analyze("AGE") %>%
+ #' @param yval (`string`)\cr value of y-axis. Options are `Survival` (default) and `Failure` probability. |
||
| 26 |
- #' build_table(tern_ex_adsl)+ #' @param censor_show (`flag`)\cr whether to show censored. |
||
| 27 |
- #'+ #' @param xlab (`string`)\cr label of x-axis. |
||
| 28 |
- #' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2))+ #' @param ylab (`string`)\cr label of y-axis. |
||
| 29 |
- #'+ #' @param ylim (`vector` of `numeric`)\cr vector of length 2 containing lower and upper limits for the y-axis. |
||
| 30 |
- #' @export+ #' If `NULL` (default), the minimum and maximum y-values displayed are used as limits. |
||
| 31 |
- to_string_matrix <- function(x, widths = NULL, max_width = NULL,+ #' @param title (`string`)\cr title for plot. |
||
| 32 |
- hsep = formatters::default_hsep(),+ #' @param footnotes (`string`)\cr footnotes for plot. |
||
| 33 |
- with_spaces = TRUE, print_txt_to_copy = FALSE) {
+ #' @param col (`character`)\cr lines colors. Length of a vector should be equal |
||
| 34 | -5x | +
- checkmate::assert_flag(with_spaces)+ #' to number of strata from [survival::survfit()]. |
|
| 35 | -5x | +
- checkmate::assert_flag(print_txt_to_copy)+ #' @param lty (`numeric`)\cr line type. Length of a vector should be equal |
|
| 36 | -5x | +
- checkmate::assert_int(max_width, null.ok = TRUE)+ #' to number of strata from [survival::survfit()]. |
|
| 37 |
-
+ #' @param lwd (`numeric`)\cr line width. Length of a vector should be equal |
||
| 38 | -5x | +
- if (inherits(x, "MatrixPrintForm")) {
+ #' to number of strata from [survival::survfit()]. |
|
| 39 | -! | +
- tx <- x+ #' @param pch (`numeric`, `string`)\cr value or character of points symbol to indicate censored cases. |
|
| 40 |
- } else {
+ #' @param size (`numeric`)\cr size of censored point, a class of `unit`. |
||
| 41 | -5x | +
- tx <- matrix_form(x, TRUE)+ #' @param max_time (`numeric`)\cr maximum value to show on X axis. Only data values less than or up to |
|
| 42 |
- }+ #' this threshold value will be plotted (defaults to `NULL`). |
||
| 43 |
-
+ #' @param font_size (`number`)\cr font size to be used. |
||
| 44 | -5x | +
- tf_wrap <- FALSE+ #' @param ci_ribbon (`flag`)\cr draw the confidence interval around the Kaplan-Meier curve. |
|
| 45 | -5x | +
- if (!is.null(max_width)) {
+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control outlook of the Kaplan-Meier curve. |
|
| 46 | -! | +
- tf_wrap <- TRUE+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk |
|
| 47 |
- }+ #' matching the main grid of the Kaplan-Meier curve. |
||
| 48 |
-
+ #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
||
| 49 |
- # Producing the matrix to test+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
||
| 50 | -5x | +
- if (with_spaces) {
+ #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the |
|
| 51 | -! | +
- out <- strsplit(toString(tx, widths = widths, tf_wrap = tf_wrap, max_width = max_width, hsep = hsep), "\\n")[[1]]+ #' median survival time per group. |
|
| 52 |
- } else {
+ #' @param annot_coxph (`flag`)\cr add the annotation table from a [survival::coxph()] model. |
||
| 53 | -5x | +
- out <- tx$strings+ #' @param annot_stats (`string`)\cr statistics annotations to add to the plot. Options are |
|
| 54 |
- }+ #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time). |
||
| 55 |
-
+ #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics |
||
| 56 |
- # Printing to console formatted output that needs to be copied in "expected"+ #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added. |
||
| 57 | -5x | +
- if (print_txt_to_copy) {
+ #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified by using |
|
| 58 | -! | +
- out_tmp <- out+ #' the helper function [control_coxph()]. Some possible parameter options are: |
|
| 59 | -! | +
- if (!with_spaces) {
+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. |
|
| 60 | -! | +
- out_tmp <- apply(out, 1, paste0, collapse = '", "')+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
|
| 61 |
- }+ #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`, |
||
| 62 | -! | +
- cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()] |
|
| 63 |
- }+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
||
| 64 |
-
+ #' @param ref_group_coxph (`character`)\cr level of arm variable to use as reference group in calculations for |
||
| 65 |
- # Return values+ #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable. |
||
| 66 | -5x | +
- return(out)+ #' @param annot_coxph_ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the |
|
| 67 |
- }+ #' `annot_coxph` table. If `FALSE` (default), only comparison groups will be printed in `annot_coxph` table labels. |
||
| 68 |
-
+ #' @param position_coxph (`numeric`)\cr x and y positions for plotting [survival::coxph()] model. |
||
| 69 |
- #' Blank for Missing Input+ #' @param position_surv_med (`numeric`)\cr x and y positions for plotting annotation table estimating median survival |
||
| 70 |
- #'+ #' time per group. |
||
| 71 |
- #' Helper function to use in tabulating model results.+ #' @param width_annots (named `list` of `unit`s)\cr a named list of widths for annotation tables with names `surv_med` |
||
| 72 |
- #'+ #' (median survival time table) and `coxph` ([survival::coxph()] model table), where each value is the width |
||
| 73 |
- #' @param x (`vector`)\cr input for a cell.+ #' (in units) to implement when printing the annotation table. |
||
| 75 |
- #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise+ #' @return A `grob` of class `gTree`. |
||
| 76 |
- #' the unlisted version of `x`.+ #' |
||
| 77 |
- #'+ #' @examples |
||
| 78 |
- #' @keywords internal+ #' \donttest{
|
||
| 79 |
- unlist_and_blank_na <- function(x) {
+ #' library(dplyr) |
||
| 80 | -267x | +
- unl <- unlist(x)+ #' library(ggplot2) |
|
| 81 | -267x | +
- if (all(is.na(unl))) {
+ #' library(survival) |
|
| 82 | -161x | +
- character()+ #' library(grid) |
|
| 83 |
- } else {
+ #' library(nestcolor) |
||
| 84 | -106x | +
- unl+ #' |
|
| 85 |
- }+ #' df <- tern_ex_adtte %>% |
||
| 86 |
- }+ #' filter(PARAMCD == "OS") %>% |
||
| 87 |
-
+ #' mutate(is_event = CNSR == 0) |
||
| 88 |
- #' Constructor for Content Functions given Data Frame with Flag Input+ #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD") |
||
| 90 |
- #' This can be useful for tabulating model results.+ #' # 1. Example - basic option |
||
| 92 |
- #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the+ #' res <- g_km(df = df, variables = variables) |
||
| 93 |
- #' content function.+ #' res <- g_km(df = df, variables = variables, yval = "Failure") |
||
| 94 |
- #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned.+ #' res <- g_km( |
||
| 95 |
- #' @param format (`string`)\cr `rtables` format to use.+ #' df = df, |
||
| 96 |
- #'+ #' variables = variables, |
||
| 97 |
- #' @return A content function which gives `df$analysis_var` at the row identified by+ #' control_surv = control_surv_timepoint(conf_level = 0.9), |
||
| 98 |
- #' `.df_row$flag` in the given format.+ #' col = c("grey25", "grey50", "grey75"),
|
||
| 99 |
- #'+ #' annot_at_risk_title = FALSE |
||
| 100 |
- #' @keywords internal+ #' ) |
||
| 101 |
- cfun_by_flag <- function(analysis_var,+ #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal()) |
||
| 102 |
- flag_var,+ #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal(), lty = 1:3) |
||
| 103 |
- format = "xx",+ #' res <- g_km(df = df, variables = variables, max = 2000) |
||
| 104 |
- .indent_mods = NULL) {
+ #' res <- g_km( |
||
| 105 | -61x | +
- checkmate::assert_string(analysis_var)+ #' df = df, |
|
| 106 | -61x | +
- checkmate::assert_string(flag_var)+ #' variables = variables, |
|
| 107 | -61x | +
- function(df, labelstr) {
+ #' annot_stats = c("min", "median"),
|
|
| 108 | -265x | +
- row_index <- which(df[[flag_var]])+ #' annot_stats_vlines = TRUE |
|
| 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),+ #' # 2. Example - Arrange several KM curve on a single graph device |
|
| 112 | -265x | +
- labelstr+ #' |
|
| 113 |
- )+ #' # 2.1 Use case: A general graph on the top, a zoom on the bottom. |
||
| 114 |
- }+ #' grid.newpage() |
||
| 115 |
- }+ #' lyt <- grid.layout(nrow = 2, ncol = 1) %>% |
||
| 116 |
-
+ #' viewport(layout = .) %>% |
||
| 117 |
- #' Content Row Function to Add Row Total to Labels+ #' pushViewport() |
||
| 119 |
- #' This takes the label of the latest row split level and adds the row total from `df` in parentheses.+ #' res <- g_km( |
||
| 120 |
- #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than+ #' df = df, variables = variables, newpage = FALSE, annot_surv_med = FALSE, |
||
| 121 |
- #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`.+ #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1) |
||
| 122 |
- #'+ #' ) |
||
| 123 |
- #' @inheritParams argument_convention+ #' res <- g_km( |
||
| 124 |
- #'+ #' df = df, variables = variables, max = 1000, newpage = FALSE, annot_surv_med = FALSE, |
||
| 125 |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ #' ggtheme = theme_dark(), |
||
| 126 |
- #'+ #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1) |
||
| 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 |
- #'+ #' # 2.1 Use case: No annotations on top, annotated graph on bottom |
||
| 130 |
- #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from+ #' grid.newpage() |
||
| 131 |
- #' `alt_counts_df` instead of `df`.+ #' lyt <- grid.layout(nrow = 2, ncol = 1) %>% |
||
| 132 |
- #'+ #' viewport(layout = .) %>% |
||
| 133 |
- #' @keywords internal+ #' pushViewport() |
||
| 134 |
- c_label_n <- function(df,+ #' |
||
| 135 |
- labelstr,+ #' res <- g_km( |
||
| 136 |
- .N_row) { # nolint
+ #' df = df, variables = variables, newpage = FALSE, |
||
| 137 | -270x | +
- label <- paste0(labelstr, " (N=", .N_row, ")")+ #' annot_surv_med = FALSE, annot_at_risk = FALSE, |
|
| 138 | -270x | +
- in_rows(+ #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1) |
|
| 139 | -270x | +
- .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)),+ #' ) |
|
| 140 | -270x | +
- .formats = c(row_count = function(x, ...) "")+ #' res <- g_km( |
|
| 141 |
- )+ #' df = df, variables = variables, max = 2000, newpage = FALSE, annot_surv_med = FALSE, |
||
| 142 |
- }+ #' annot_at_risk = TRUE, |
||
| 143 |
-
+ #' ggtheme = theme_dark(), |
||
| 144 |
- #' Content Row Function to Add `alt_counts_df` Row Total to Labels+ #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1) |
||
| 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`+ #' # Add annotation from a pairwise coxph analysis |
||
| 148 |
- #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`.+ #' g_km( |
||
| 149 |
- #'+ #' df = df, variables = variables, |
||
| 150 |
- #' @inheritParams argument_convention+ #' annot_coxph = TRUE |
||
| 151 |
- #'+ #' ) |
||
| 152 |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ #' |
||
| 153 |
- #'+ #' # Change widths/sizes of surv_med and coxph annotation tables. |
||
| 154 |
- #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead+ #' g_km( |
||
| 155 |
- #' of `alt_counts_df`.+ #' df = df, variables = c(variables, list(strata = "SEX")), |
||
| 156 |
- #'+ #' annot_coxph = TRUE, |
||
| 157 |
- #' @keywords internal+ #' width_annots = list(surv_med = grid::unit(2, "in"), coxph = grid::unit(3, "in")) |
||
| 158 |
- c_label_n_alt <- function(df,+ #' ) |
||
| 159 |
- labelstr,+ #' |
||
| 160 |
- .alt_df_row) {
+ #' g_km( |
||
| 161 | -7x | +
- N_row_alt <- nrow(.alt_df_row) # nolint+ #' df = df, variables = c(variables, list(strata = "SEX")), |
|
| 162 | -7x | +
- label <- paste0(labelstr, " (N=", N_row_alt, ")")+ #' font_size = 15, |
|
| 163 | -7x | +
- in_rows(+ #' annot_coxph = TRUE, |
|
| 164 | -7x | +
- .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)),+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
|
| 165 | -7x | +
- .formats = c(row_count = function(x, ...) "")+ #' position_coxph = c(0.5, 0.5) |
|
| 166 |
- )+ #' ) |
||
| 167 |
- }+ #' |
||
| 168 |
-
+ #' # Change position of the treatment group annotation table. |
||
| 169 |
- #' Layout Creating Function to Add Row Total Counts+ #' g_km( |
||
| 170 |
- #'+ #' df = df, variables = c(variables, list(strata = "SEX")), |
||
| 171 |
- #' @description `r lifecycle::badge("stable")`
+ #' font_size = 15, |
||
| 172 |
- #'+ #' annot_coxph = TRUE, |
||
| 173 |
- #' This works analogously to [rtables::add_colcounts()] but on the rows. This function+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
||
| 174 |
- #' is a wrapper for [rtables::summarize_row_groups()].+ #' position_surv_med = c(1, 0.7) |
||
| 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`.+ #' @export |
||
| 179 |
- #'+ g_km <- function(df, |
||
| 180 |
- #' @return A modified layout where the latest row split labels now have the row-wise+ variables, |
||
| 181 |
- #' total counts (i.e. without column-based subsetting) attached in parentheses.+ control_surv = control_surv_timepoint(), |
||
| 182 |
- #'+ col = NULL, |
||
| 183 |
- #' @note Row count values are contained in these row count rows but are not displayed+ lty = NULL, |
||
| 184 |
- #' so that they are not considered zero rows by default when pruning.+ lwd = .5, |
||
| 185 |
- #'+ censor_show = TRUE, |
||
| 186 |
- #' @examples+ pch = 3, |
||
| 187 |
- #' basic_table() %>%+ size = 2, |
||
| 188 |
- #' split_cols_by("ARM") %>%
+ max_time = NULL, |
||
| 189 |
- #' add_colcounts() %>%+ xticks = NULL, |
||
| 190 |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ xlab = "Days", |
||
| 191 |
- #' add_rowcounts() %>%+ yval = c("Survival", "Failure"),
|
||
| 192 |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ ylab = paste(yval, "Probability"), |
||
| 193 |
- #' build_table(DM)+ ylim = NULL, |
||
| 194 |
- #'+ title = NULL, |
||
| 195 |
- #' @export+ footnotes = NULL, |
||
| 196 |
- add_rowcounts <- function(lyt, alt_counts = FALSE) {
+ draw = TRUE, |
||
| 197 | -6x | +
- summarize_row_groups(+ newpage = TRUE, |
|
| 198 | -6x | +
- lyt,+ gp = NULL, |
|
| 199 | -6x | +
- cfun = if (alt_counts) c_label_n_alt else c_label_n+ vp = NULL, |
|
| 200 |
- )+ name = NULL, |
||
| 201 |
- }+ font_size = 12, |
||
| 202 |
-
+ ci_ribbon = FALSE, |
||
| 203 |
- #' Obtain Column Indices+ ggtheme = nestcolor::theme_nest(), |
||
| 204 |
- #'+ annot_at_risk = TRUE, |
||
| 205 |
- #' @description `r lifecycle::badge("stable")`
+ annot_at_risk_title = TRUE, |
||
| 206 |
- #'+ annot_surv_med = TRUE, |
||
| 207 |
- #' Helper function to extract column indices from a `VTableTree` for a given+ annot_coxph = FALSE, |
||
| 208 |
- #' vector of column names.+ annot_stats = NULL, |
||
| 209 |
- #'+ annot_stats_vlines = FALSE, |
||
| 210 |
- #' @param table_tree (`VTableTree`)\cr table to extract the indices from.+ control_coxph_pw = control_coxph(), |
||
| 211 |
- #' @param col_names (`character`)\cr vector of column names.+ ref_group_coxph = NULL, |
||
| 212 |
- #'+ annot_coxph_ref_lbls = FALSE, |
||
| 213 |
- #' @return A vector of column indices.+ position_coxph = c(-0.03, -0.02), |
||
| 214 |
- #'+ position_surv_med = c(0.95, 0.9), |
||
| 215 |
- #' @export+ width_annots = list(surv_med = grid::unit(0.3, "npc"), coxph = grid::unit(0.4, "npc"))) {
|
||
| 216 | -+ | 3x |
- h_col_indices <- function(table_tree, col_names) {
+ checkmate::assert_list(variables) |
| 217 | -1232x | +3x |
- checkmate::assert_class(table_tree, "VTableNodeInfo")+ checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
|
| 218 | -1232x | +3x |
- checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE)+ checkmate::assert_string(title, null.ok = TRUE) |
| 219 | -1232x | +3x |
- match(col_names, names(attr(col_info(table_tree), "cextra_args")))+ checkmate::assert_string(footnotes, null.ok = TRUE) |
| 220 | -+ | 3x |
- }+ checkmate::assert_character(col, null.ok = TRUE) |
| 221 | -+ | 3x |
-
+ checkmate::assert_subset(annot_stats, c("median", "min"))
|
| 222 | -+ | 3x |
- #' Labels or Names of List Elements+ checkmate::assert_logical(annot_stats_vlines) |
| 223 | -+ | 3x |
- #'+ checkmate::assert_true(all(sapply(width_annots, grid::is.unit))) |
| 224 |
- #' Internal helper function for working with nested statistic function results which typically+ |
||
| 225 | -+ | 3x |
- #' don't have labels but names that we can use.+ tte <- variables$tte |
| 226 | -+ | 3x |
- #'+ is_event <- variables$is_event |
| 227 | -+ | 3x |
- #' @param x a list.+ arm <- variables$arm |
| 228 |
- #'+ |
||
| 229 | -+ | 3x |
- #' @return A `character` vector with the labels or names for the list elements.+ assert_valid_factor(df[[arm]]) |
| 230 | -+ | 3x |
- #'+ assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm)) |
| 231 | -+ | 3x |
- #' @keywords internal+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
| 232 | -+ | 3x |
- labels_or_names <- function(x) {
+ checkmate::assert_numeric(df[[tte]], min.len = 1, any.missing = FALSE) |
| 233 | -131x | +
- checkmate::assert_multi_class(x, c("data.frame", "list"))
+
|
|
| 234 | -131x | +3x |
- labs <- sapply(x, obj_label)+ armval <- as.character(unique(df[[arm]])) |
| 235 | -131x | +3x |
- nams <- rlang::names2(x)+ if (annot_coxph && length(armval) < 2) {
|
| 236 | -131x | +! |
- label_is_null <- sapply(labs, is.null)+ stop(paste( |
| 237 | -131x | +! |
- result <- unlist(ifelse(label_is_null, nams, labs))+ "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`", |
| 238 | -131x | +! |
- return(result)+ "in order to calculate the hazard ratio." |
| 239 |
- }+ )) |
||
| 240 | -+ | 3x |
-
+ } else if (length(armval) > 1) {
|
| 241 | -+ | 3x |
- #' Convert to `rtable`+ armval <- NULL |
| 242 |
- #'+ } |
||
| 243 | -+ | 3x |
- #' @description `r lifecycle::badge("stable")`
+ yval <- match.arg(yval) |
| 244 | -+ | 3x |
- #'+ formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
|
| 245 | -+ | 3x |
- #' This is a new generic function to convert objects to `rtable` tables.+ fit_km <- survival::survfit( |
| 246 | -+ | 3x |
- #'+ formula = formula, |
| 247 | -+ | 3x |
- #' @param x the object which should be converted to an `rtable`.+ data = df, |
| 248 | -+ | 3x |
- #' @param ... additional arguments for methods.+ conf.int = control_surv$conf_level, |
| 249 | -+ | 3x |
- #'+ conf.type = control_surv$conf_type |
| 250 |
- #' @return An `rtables` table object. Note that the concrete class will depend on the method used.+ ) |
||
| 251 | -+ | 3x |
- #'+ data_plot <- h_data_plot( |
| 252 | -+ | 3x |
- #' @export+ fit_km = fit_km, |
| 253 | -+ | 3x |
- as.rtable <- function(x, ...) { # nolint
+ armval = armval, |
| 254 | 3x |
- UseMethod("as.rtable", x)
+ max_time = max_time |
|
| 255 |
- }+ ) |
||
| 257 | -+ | 3x |
- #' @describeIn as.rtable method for converting `data.frame` that contain numeric columns to `rtable`.+ xticks <- h_xticks(data = data_plot, xticks = xticks, max_time = max_time) |
| 258 | -+ | 3x |
- #'+ gg <- h_ggkm( |
| 259 | -+ | 3x |
- #' @param format the format which should be used for the columns.+ data = data_plot, |
| 260 | -+ | 3x |
- #'+ censor_show = censor_show, |
| 261 | -+ | 3x |
- #' @method as.rtable data.frame+ pch = pch, |
| 262 | -+ | 3x |
- #'+ size = size, |
| 263 | -+ | 3x |
- #' @examples+ xticks = xticks, |
| 264 | -+ | 3x |
- #' x <- data.frame(+ xlab = xlab, |
| 265 | -+ | 3x |
- #' a = 1:10,+ yval = yval, |
| 266 | -+ | 3x |
- #' b = rnorm(10)+ ylab = ylab, |
| 267 | -+ | 3x |
- #' )+ ylim = ylim, |
| 268 | -+ | 3x |
- #' as.rtable(x)+ title = title, |
| 269 | -+ | 3x |
- #'+ footnotes = footnotes, |
| 270 | -+ | 3x |
- #' @export+ max_time = max_time, |
| 271 | -+ | 3x |
- as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
+ lwd = lwd, |
| 272 | 3x |
- checkmate::assert_numeric(unlist(x))+ lty = lty, |
|
| 273 | -2x | +3x |
- do.call(+ col = col, |
| 274 | -2x | +3x |
- rtable,+ ggtheme = ggtheme, |
| 275 | -2x | +3x |
- c(+ ci_ribbon = ci_ribbon |
| 276 | -2x | +
- list(+ ) |
|
| 277 | -2x | +
- header = labels_or_names(x),+ |
|
| 278 | -2x | +3x |
- format = format+ if (!is.null(annot_stats)) {
|
| 279 | -+ | ! |
- ),+ if ("median" %in% annot_stats) {
|
| 280 | -2x | +! |
- Map(+ fit_km_all <- survival::survfit( |
| 281 | -2x | +! |
- function(row, row_name) {
+ formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
|
| 282 | -20x | +! |
- do.call(+ data = df, |
| 283 | -20x | +! |
- rrow,+ conf.int = control_surv$conf_level, |
| 284 | -20x | +! |
- c(as.list(unname(row)),+ conf.type = control_surv$conf_type |
| 285 | -20x | +
- row.name = row_name+ ) |
|
| 286 | -+ | ! |
- )+ gg <- gg + |
| 287 | -+ | ! |
- )+ geom_text( |
| 288 | -+ | ! |
- },+ size = 8 / ggplot2::.pt, col = 1, |
| 289 | -2x | +! |
- row = as.data.frame(t(x)),+ x = stats::median(fit_km_all) + 0.065 * max(data_plot$time), |
| 290 | -2x | +! |
- row_name = rownames(x)+ y = ifelse(yval == "Survival", 0.62, 0.38), |
| 291 | -+ | ! |
- )+ label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
|
| 292 |
- )+ ) |
||
| 293 | -+ | ! |
- )+ if (annot_stats_vlines) {
|
| 294 | -+ | ! |
- }+ gg <- gg + |
| 295 | -+ | ! |
-
+ geom_segment(aes(x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf), |
| 296 | -+ | ! |
- #' Split parameters+ linetype = 2, col = "darkgray" |
| 297 |
- #'+ ) |
||
| 298 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 299 |
- #'+ } |
||
| 300 | -+ | ! |
- #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant+ if ("min" %in% annot_stats) {
|
| 301 | -+ | ! |
- #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to+ min_fu <- min(df[[tte]]) |
| 302 | -+ | ! |
- #' specific analysis function.+ gg <- gg + |
| 303 | -+ | ! |
- #'+ geom_text( |
| 304 | -+ | ! |
- #' @param param (`vector`)\cr the parameter to be split.+ size = 8 / ggplot2::.pt, col = 1, |
| 305 | -+ | ! |
- #' @param value (`vector`)\cr the value used to split.+ x = min_fu + max(data_plot$time) * ifelse(yval == "Survival", 0.05, 0.07), |
| 306 | -+ | ! |
- #' @param f (`list` of `vectors`)\cr the reference to make the split+ y = ifelse(yval == "Survival", 1.0, 0.05), |
| 307 | -+ | ! |
- #'+ label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
|
| 308 |
- #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`.+ ) |
||
| 309 | -+ | ! |
- #'+ if (annot_stats_vlines) {
|
| 310 | -+ | ! |
- #' @examples+ gg <- gg + |
| 311 | -+ | ! |
- #' f <- list(+ geom_segment(aes(x = min_fu, xend = min_fu, y = Inf, yend = -Inf), linetype = 2, col = "darkgray") |
| 312 |
- #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ } |
||
| 313 |
- #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ } |
||
| 314 | -+ | ! |
- #' )+ gg <- gg + ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(shape = NA, label = ""))) |
| 315 |
- #'+ } |
||
| 316 |
- #' .stats <- c("pt_at_risk", "rate_diff")
+
|
||
| 317 | -+ | 3x |
- #' h_split_param(.stats, .stats, f = f)+ g_el <- h_decompose_gg(gg) |
| 318 |
- #'+ |
||
| 319 | -+ | 3x |
- #' # $surv+ if (annot_at_risk) {
|
| 320 |
- #' # [1] "pt_at_risk"+ # This is the content of the table that will be below the graph. |
||
| 321 | -+ | 2x |
- #' #+ annot_tbl <- summary(fit_km, time = xticks) |
| 322 | -+ | 2x |
- #' # $surv_diff+ annot_tbl <- if (is.null(fit_km$strata)) {
|
| 323 | -+ | ! |
- #' # [1] "rate_diff"+ data.frame( |
| 324 | -+ | ! |
- #'+ n.risk = annot_tbl$n.risk, |
| 325 | -+ | ! |
- #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
+ time = annot_tbl$time, |
| 326 | -+ | ! |
- #' h_split_param(.formats, names(.formats), f = f)+ strata = as.factor(armval) |
| 327 |
- #'+ ) |
||
| 328 |
- #' # $surv+ } else {
|
||
| 329 | -+ | 2x |
- #' # pt_at_risk event_free_rate+ strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
| 330 | -+ | 2x |
- #' # "xx" "xxx"+ levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
| 331 | -+ | 2x |
- #' #+ data.frame( |
| 332 | -+ | 2x |
- #' # $surv_diff+ n.risk = annot_tbl$n.risk, |
| 333 | -+ | 2x |
- #' # NULL+ time = annot_tbl$time, |
| 334 | -+ | 2x |
- #'+ strata = annot_tbl$strata |
| 335 |
- #' @export+ ) |
||
| 336 |
- h_split_param <- function(param,+ } |
||
| 337 |
- value,+ |
||
| 338 | -+ | 2x |
- f) {
+ grobs_patient <- h_grob_tbl_at_risk( |
| 339 | -25x | +2x |
- y <- lapply(f, function(x) param[value %in% x])+ data = data_plot, |
| 340 | -25x | +2x |
- lapply(y, function(x) if (length(x) == 0) NULL else x)+ annot_tbl = annot_tbl, |
| 341 | -+ | 2x |
- }+ xlim = max(max_time, data_plot$time, xticks), |
| 342 | -+ | 2x |
-
+ title = annot_at_risk_title |
| 343 |
- #' Get Selected Statistics Names+ ) |
||
| 344 |
- #'+ } |
||
| 345 |
- #' Helper function to be used for creating `afun`.+ |
||
| 346 | -+ | 3x |
- #'+ if (annot_at_risk || annot_surv_med || annot_coxph) {
|
| 347 | -+ | 2x |
- #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means+ lyt <- h_km_layout( |
| 348 | -+ | 2x |
- #' in this context that all default statistics should be used.+ data = data_plot, g_el = g_el, title = title, footnotes = footnotes, |
| 349 | -+ | 2x |
- #' @param all_stats (`character`)\cr all statistics which can be selected here potentially.+ annot_at_risk = annot_at_risk, annot_at_risk_title = annot_at_risk_title |
| 350 |
- #'+ ) |
||
| 351 | -+ | 2x |
- #' @return A `character` vector with the selected statistics.+ at_risk_ttl <- as.numeric(annot_at_risk_title) |
| 352 | -+ | 2x |
- #'+ ttl_row <- as.numeric(!is.null(title)) |
| 353 | -+ | 2x |
- #' @keywords internal+ foot_row <- as.numeric(!is.null(footnotes)) |
| 354 | -+ | 2x |
- afun_selected_stats <- function(.stats, all_stats) {
+ km_grob <- grid::gTree( |
| 355 | 2x |
- checkmate::assert_character(.stats, null.ok = TRUE)+ vp = grid::viewport(layout = lyt, height = .95, width = .95), |
|
| 356 | 2x |
- checkmate::assert_character(all_stats)+ children = grid::gList( |
|
| 357 | -2x | +
- if (is.null(.stats)) {
+ # Title. |
|
| 358 | -1x | +2x |
- all_stats+ if (ttl_row == 1) {
|
| 359 | -+ | 1x |
- } else {
+ grid::gTree( |
| 360 | 1x |
- intersect(.stats, all_stats)+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 2), |
|
| 361 | -+ | 1x |
- }+ children = grid::gList(grid::textGrob(label = title, x = grid::unit(0, "npc"), hjust = 0)) |
| 362 |
- }+ ) |
||
| 363 |
-
+ }, |
||
| 364 |
- #' Add Variable Labels to Top Left Corner in Table+ |
||
| 365 |
- #'+ # The Kaplan - Meier curve (top-right corner). |
||
| 366 | -+ | 2x |
- #' @description `r lifecycle::badge("stable")`
+ grid::gTree( |
| 367 | -+ | 2x |
- #'+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2), |
| 368 | -+ | 2x |
- #' Helper layout creating function to just append the variable labels of a given variables vector+ children = grid::gList(g_el$panel) |
| 369 |
- #' from a given dataset in the top left corner. If a variable label is not found then the+ ), |
||
| 370 |
- #' variable name itself is used instead. Multiple variable labels are concatenated with slashes.+ |
||
| 371 |
- #'+ # Survfit summary table (top-right corner). |
||
| 372 | -+ | 2x |
- #' @inheritParams argument_convention+ if (annot_surv_med) {
|
| 373 | -+ | 2x |
- #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.+ grid::gTree( |
| 374 | -+ | 2x |
- #' @param indent (`integer`)\cr non-negative number of nested indent space, default to 0L which means no indent.+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2), |
| 375 | -+ | 2x |
- #' 1L means two spaces indent, 2L means four spaces indent and so on.+ children = h_grob_median_surv( |
| 376 | -+ | 2x |
- #'+ fit_km = fit_km, |
| 377 | -+ | 2x |
- #' @return A modified layout with the new variable label(s) added to the top-left material.+ armval = armval, |
| 378 | -+ | 2x |
- #'+ x = position_surv_med[1], |
| 379 | -+ | 2x |
- #' @note This is not an optimal implementation of course, since we are using here the data set+ y = position_surv_med[2], |
| 380 | -+ | 2x |
- #' itself during the layout creation. When we have a more mature `rtables` implementation then+ width = if (!is.null(width_annots[["surv_med"]])) width_annots[["surv_med"]] else grid::unit(0.3, "npc"), |
| 381 | -+ | 2x |
- #' this will also be improved or not necessary anymore.+ ttheme = gridExtra::ttheme_default(base_size = font_size) |
| 382 |
- #'+ ) |
||
| 383 |
- #' @examples+ ) |
||
| 384 |
- #' lyt <- basic_table() %>%+ }, |
||
| 385 | -+ | 2x |
- #' split_cols_by("ARM") %>%
+ if (annot_coxph) {
|
| 386 | -+ | 1x |
- #' add_colcounts() %>%+ grid::gTree( |
| 387 | -+ | 1x |
- #' split_rows_by("SEX") %>%
+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2), |
| 388 | -+ | 1x |
- #' append_varlabels(DM, "SEX") %>%+ children = h_grob_coxph( |
| 389 | -+ | 1x |
- #' analyze("AGE", afun = mean) %>%
+ df = df, |
| 390 | -+ | 1x |
- #' append_varlabels(DM, "AGE", indent = 1)+ variables = variables, |
| 391 | -+ | 1x |
- #' build_table(lyt, DM)+ control_coxph_pw = control_coxph_pw, |
| 392 | -+ | 1x |
- #'+ ref_group_coxph = ref_group_coxph, |
| 393 | -+ | 1x |
- #' lyt <- basic_table() %>%+ annot_coxph_ref_lbls = annot_coxph_ref_lbls, |
| 394 | -+ | 1x |
- #' split_cols_by("ARM") %>%
+ x = position_coxph[1], |
| 395 | -+ | 1x |
- #' split_rows_by("SEX") %>%
+ y = position_coxph[2], |
| 396 | -+ | 1x |
- #' analyze("AGE", afun = mean) %>%
+ width = if (!is.null(width_annots[["coxph"]])) width_annots[["coxph"]] else grid::unit(0.4, "npc"), |
| 397 | -+ | 1x |
- #' append_varlabels(DM, c("SEX", "AGE"))
+ ttheme = gridExtra::ttheme_default( |
| 398 | -+ | 1x |
- #' build_table(lyt, DM)+ base_size = font_size, |
| 399 | -+ | 1x |
- #'+ padding = grid::unit(c(1, .5), "lines"), |
| 400 | -+ | 1x |
- #' @export+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
|
| 401 |
- append_varlabels <- function(lyt, df, vars, indent = 0L) {
+ ) |
||
| 402 | -3x | +
- if (checkmate::test_flag(indent)) {
+ ) |
|
| 403 | -! | +
- warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
+ ) |
|
| 404 | -! | +
- indent <- as.integer(indent)+ }, |
|
| 405 |
- }+ |
||
| 406 |
-
+ # Add the y-axis annotation (top-left corner). |
||
| 407 | -3x | +2x |
- checkmate::assert_data_frame(df)+ grid::gTree( |
| 408 | -3x | +2x |
- checkmate::assert_character(vars)+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 1), |
| 409 | -3x | +2x |
- checkmate::assert_count(indent)+ children = h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis) |
| 410 |
-
+ ), |
||
| 411 | -3x | +
- lab <- formatters::var_labels(df[vars], fill = TRUE)+ |
|
| 412 | -3x | +
- lab <- paste(lab, collapse = " / ")+ # Add the x-axis annotation (second row below the Kaplan Meier Curve). |
|
| 413 | -3x | +2x |
- space <- paste(rep(" ", indent * 2), collapse = "")
+ grid::gTree( |
| 414 | -3x | +2x |
- lab <- paste0(space, lab)+ vp = grid::viewport(layout.pos.row = 2 + ttl_row, layout.pos.col = 2), |
| 415 | -+ | 2x |
-
+ children = grid::gList(rbind(g_el$xaxis, g_el$xlab)) |
| 416 | -3x | +
- append_topleft(lyt, lab)+ ), |
|
| 417 |
- }+ |
||
| 418 |
-
+ # Add the legend. |
||
| 419 | -+ | 2x |
- #' Default string replacement for `NA` values+ grid::gTree( |
| 420 | -+ | 2x |
- #'+ vp = grid::viewport(layout.pos.row = 3 + ttl_row, layout.pos.col = 2), |
| 421 | -+ | 2x |
- #' @description `r lifecycle::badge("stable")`
+ children = grid::gList(g_el$guide) |
| 422 |
- #'+ ), |
||
| 423 |
- #' The default string used to represent `NA` values. This value is used as the default+ |
||
| 424 |
- #' value for the `na_str` argument throughout the `tern` package, and printed in place+ # Add the table with patient-at-risk numbers. |
||
| 425 | -+ | 2x |
- #' of `NA` values in output tables. If not specified for each `tern` function by the user+ if (annot_at_risk && annot_at_risk_title) {
|
| 426 | -+ | 2x |
- #' via the `na_str` argument, or in the R environment options via [set_default_na_str()],+ grid::gTree( |
| 427 | -+ | 2x |
- #' then `NA` is used.+ vp = grid::viewport(layout.pos.row = 4 + ttl_row, layout.pos.col = 1), |
| 428 | -+ | 2x |
- #'+ children = grobs_patient$title |
| 429 |
- #' @param na_str (`string`)\cr Single string value to set in the R environment options as+ ) |
||
| 430 |
- #' the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the
+ }, |
||
| 431 | -+ | 2x |
- #' current value set in the R environment (defaults to `NULL` if not set).+ if (annot_at_risk) {
|
| 432 | -+ | 2x |
- #'+ grid::gTree( |
| 433 | -+ | 2x |
- #' @name default_na_str+ vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 2), |
| 434 | -+ | 2x |
- NULL+ children = grobs_patient$at_risk |
| 435 |
-
+ ) |
||
| 436 |
- #' @describeIn default_na_str Getter for default `NA` value replacement string.+ }, |
||
| 437 | -+ | 2x |
- #'+ if (annot_at_risk) {
|
| 438 | -+ | 2x |
- #' @return+ grid::gTree( |
| 439 | -+ | 2x |
- #' * `default_na_str` returns the current value if an R environment option has been set+ vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 1), |
| 440 | -+ | 2x |
- #' for `"tern_default_na_str"`, or `NA_character_` otherwise.+ children = grobs_patient$label |
| 441 |
- #'+ ) |
||
| 442 |
- #' @examples+ }, |
||
| 443 | -+ | 2x |
- #' # Default settings+ if (annot_at_risk) {
|
| 444 |
- #' default_na_str()+ # Add the x-axis for the table. |
||
| 445 | -+ | 2x |
- #' getOption("tern_default_na_str")
+ grid::gTree( |
| 446 | -+ | 2x |
- #'+ vp = grid::viewport(layout.pos.row = 5 + at_risk_ttl + ttl_row, layout.pos.col = 2), |
| 447 | -+ | 2x |
- #' # Set custom value+ children = grid::gList(rbind(g_el$xaxis, g_el$xlab)) |
| 448 |
- #' set_default_na_str("<Missing>")
+ ) |
||
| 449 |
- #'+ }, |
||
| 450 |
- #' # Settings after value has been set+ |
||
| 451 |
- #' default_na_str()+ # Footnotes. |
||
| 452 | -+ | 2x |
- #' getOption("tern_default_na_str")
+ if (foot_row == 1) {
|
| 453 | -+ | 1x |
- #'+ grid::gTree( |
| 454 | -+ | 1x |
- #' @export+ vp = grid::viewport( |
| 455 | -+ | 1x |
- default_na_str <- function() {
+ layout.pos.row = ifelse(annot_at_risk, 6 + at_risk_ttl + ttl_row, 4 + ttl_row), |
| 456 | -246x | +1x |
- getOption("tern_default_na_str", default = NA_character_)
+ layout.pos.col = 2 |
| 457 |
- }+ ), |
||
| 458 | -+ | 1x |
-
+ children = grid::gList(grid::textGrob(label = footnotes, x = grid::unit(0, "npc"), hjust = 0)) |
| 459 |
- #' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the+ ) |
||
| 460 |
- #' option `"tern_default_na_str"` within the R environment.+ } |
||
| 461 |
- #'+ ) |
||
| 462 |
- #' @return+ ) |
||
| 463 |
- #' * `set_default_na_str` has no return value.+ |
||
| 464 | -+ | 2x |
- #'+ result <- grid::gTree( |
| 465 | -+ | 2x |
- #' @export+ vp = vp, |
| 466 | -+ | 2x |
- set_default_na_str <- function(na_str) {
+ gp = gp, |
| 467 | -3x | +2x |
- checkmate::assert_character(na_str, len = 1, null.ok = TRUE)+ name = name, |
| 468 | -3x | +2x |
- options("tern_default_na_str" = na_str)
+ children = grid::gList(km_grob) |
| 469 |
- }+ ) |
| 1 | +470 |
- #' Combine Factor Levels+ } else {
|
||
| 2 | -+ | |||
| 471 | +1x |
- #'+ result <- grid::gTree( |
||
| 3 | -+ | |||
| 472 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ vp = vp, |
||
| 4 | -+ | |||
| 473 | +1x |
- #'+ gp = gp, |
||
| 5 | -+ | |||
| 474 | +1x |
- #' Combine specified old factor Levels in a single new level.+ name = name, |
||
| 6 | -+ | |||
| 475 | +1x |
- #'+ children = grid::gList(ggplot2::ggplotGrob(gg)) |
||
| 7 | +476 |
- #' @param x factor+ ) |
||
| 8 | +477 |
- #' @param levels level names to be combined+ } |
||
| 9 | +478 |
- #' @param new_level name of new level+ |
||
| 10 | -+ | |||
| 479 | +3x |
- #'+ if (newpage && draw) grid::grid.newpage() |
||
| 11 | -+ | |||
| 480 | +3x |
- #' @return A `factor` with the new levels.+ if (draw) grid::grid.draw(result) |
||
| 12 | -+ | |||
| 481 | +3x |
- #'+ invisible(result) |
||
| 13 | +482 |
- #' @examples+ } |
||
| 14 | +483 |
- #' x <- factor(letters[1:5], levels = letters[5:1])+ |
||
| 15 | +484 |
- #' combine_levels(x, levels = c("a", "b"))
+ #' Helper function: tidy survival fit |
||
| 16 | +485 |
#' |
||
| 17 | +486 |
- #' combine_levels(x, c("e", "b"))
+ #' @description `r lifecycle::badge("stable")`
|
||
| 18 | +487 |
#' |
||
| 19 | +488 |
- #' @export+ #' Convert the survival fit data into a data frame designed for plotting |
||
| 20 | +489 |
- combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
+ #' within `g_km`. |
||
| 21 | -4x | +|||
| 490 | +
- checkmate::assert_factor(x)+ #' |
|||
| 22 | -4x | +|||
| 491 | +
- checkmate::assert_subset(levels, levels(x))+ #' This starts from the [broom::tidy()] result, and then: |
|||
| 23 | +492 |
-
+ #' * Post-processes the `strata` column into a factor. |
||
| 24 | -4x | +|||
| 493 | +
- lvls <- levels(x)+ #' * Extends each stratum by an additional first row with time 0 and probability 1 so that |
|||
| 25 | +494 |
-
+ #' downstream plot lines start at those coordinates. |
||
| 26 | -4x | +|||
| 495 | +
- lvls[lvls %in% levels] <- new_level+ #' * Adds a `censor` column. |
|||
| 27 | +496 |
-
+ #' * Filters the rows before `max_time`. |
||
| 28 | -4x | +|||
| 497 | +
- levels(x) <- lvls+ #' |
|||
| 29 | +498 |
-
+ #' @inheritParams g_km |
||
| 30 | -4x | +|||
| 499 | +
- x+ #' @param fit_km (`survfit`)\cr result of [survival::survfit()]. |
|||
| 31 | +500 |
- }+ #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`. |
||
| 32 | +501 |
-
+ #' |
||
| 33 | +502 |
- #' Conversion of a Vector to a Factor+ #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`, |
||
| 34 | +503 |
- #'+ #' `conf.low`, `strata`, and `censor`. |
||
| 35 | +504 |
- #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user+ #' |
||
| 36 | +505 |
- #' can decide whether they prefer converting to factor manually (e.g. for full control of+ #' @examples |
||
| 37 | +506 |
- #' factor levels).+ #' \donttest{
|
||
| 38 | +507 |
- #'+ #' library(dplyr) |
||
| 39 | +508 |
- #' @param x (`atomic`)\cr object to convert.+ #' library(survival) |
||
| 40 | +509 |
- #' @param x_name (`string`)\cr name of `x`.+ #' |
||
| 41 | +510 |
- #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector.+ #' # Test with multiple arms |
||
| 42 | +511 |
- #' @param verbose defaults to `TRUE`. It prints out warnings and messages.+ #' tern_ex_adtte %>% |
||
| 43 | +512 |
- #'+ #' filter(PARAMCD == "OS") %>% |
||
| 44 | +513 |
- #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`.+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 45 | +514 |
- #'+ #' h_data_plot() |
||
| 46 | +515 |
- #' @keywords internal+ #' |
||
| 47 | +516 |
- as_factor_keep_attributes <- function(x,+ #' # Test with single arm |
||
| 48 | +517 |
- x_name = deparse(substitute(x)),+ #' tern_ex_adtte %>% |
||
| 49 | +518 |
- na_level = "<Missing>",+ #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>% |
||
| 50 | +519 |
- verbose = TRUE) {
- |
- ||
| 51 | -168x | -
- checkmate::assert_atomic(x)- |
- ||
| 52 | -168x | -
- checkmate::assert_string(x_name)- |
- ||
| 53 | -168x | -
- checkmate::assert_string(na_level)- |
- ||
| 54 | -168x | -
- checkmate::assert_flag(verbose)- |
- ||
| 55 | -168x | -
- if (is.factor(x)) {
- |
- ||
| 56 | -153x | -
- return(x)+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 57 | +520 |
- }- |
- ||
| 58 | -15x | -
- x_class <- class(x)[1]- |
- ||
| 59 | -15x | -
- if (verbose) {
- |
- ||
| 60 | -15x | -
- warning(paste(- |
- ||
| 61 | -15x | -
- "automatically converting", x_class, "variable", x_name,- |
- ||
| 62 | -15x | -
- "to factor, better manually convert to factor to avoid failures"+ #' h_data_plot(armval = "ARM B") |
||
| 63 | +521 |
- ))+ #' } |
||
| 64 | +522 |
- }- |
- ||
| 65 | -15x | -
- if (identical(length(x), 0L)) {
+ #' |
||
| 66 | -1x | +|||
| 523 | +
- warning(paste(+ #' @export |
|||
| 67 | -1x | +|||
| 524 | +
- x_name, "has length 0, this can lead to tabulation failures, better convert to factor"+ h_data_plot <- function(fit_km, |
|||
| 68 | +525 |
- ))+ armval = "All", |
||
| 69 | +526 |
- }+ max_time = NULL) {
|
||
| 70 | -15x | +527 | +10x |
- if (is.character(x)) {
+ y <- broom::tidy(fit_km) |
| 71 | -15x | +|||
| 528 | +
- x_no_na <- explicit_na(sas_na(x), label = na_level)+ |
|||
| 72 | -15x | +529 | +10x |
- if (any(na_level %in% x_no_na)) {
+ if (!is.null(fit_km$strata)) {
|
| 73 | -3x | +530 | +10x |
- do.call(+ fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
|
| 74 | -3x | +531 | +10x |
- structure,+ strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2) |
| 75 | -3x | +532 | +10x |
- c(+ strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
|
| 76 | -3x | +533 | +10x |
- list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),+ y$strata <- factor( |
| 77 | -3x | -
- attributes(x)- |
- ||
| 78 | -- |
- )- |
- ||
| 79 | -- |
- )- |
- ||
| 80 | -+ | 534 | +10x |
- } else {
+ vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2), |
| 81 | -12x | +535 | +10x |
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ levels = strata_levels |
| 82 | +536 |
- }+ ) |
||
| 83 | +537 |
} else {
|
||
| 84 | +538 | ! |
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ y$strata <- armval |
|
| 85 | +539 |
} |
||
| 86 | -- |
- }- |
- ||
| 87 | +540 | |||
| 88 | -- |
- #' Labels for Bins in Percent- |
- ||
| 89 | -- |
- #'- |
- ||
| 90 | -- |
- #' This creates labels for quantile based bins in percent. This assumes the right-closed- |
- ||
| 91 | -- |
- #' intervals as produced by [cut_quantile_bins()].- |
- ||
| 92 | -- |
- #'- |
- ||
| 93 | -- |
- #' @param probs (`proportion` vector)\cr the probabilities identifying the quantiles.- |
- ||
| 94 | -- |
- #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where- |
- ||
| 95 | -- |
- #' the boundaries 0 and 1 must not be included.- |
- ||
| 96 | -- |
- #' @param digits (`integer`)\cr number of decimal places to round the percent numbers.- |
- ||
| 97 | -- |
- #'- |
- ||
| 98 | -- |
- #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.- |
- ||
| 99 | -- |
- #'- |
- ||
| 100 | -- |
- #' @keywords internal- |
- ||
| 101 | -- |
- bins_percent_labels <- function(probs,- |
- ||
| 102 | -+ | |||
| 541 | +10x |
- digits = 0) {
+ y_by_strata <- split(y, y$strata) |
||
| 103 | -1x | +542 | +10x |
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ y_by_strata_extended <- lapply( |
| 104 | -1x | +543 | +10x |
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ y_by_strata, |
| 105 | -8x | +544 | +10x |
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ FUN = function(tbl) {
|
| 106 | -8x | +545 | +30x |
- percent <- round(probs * 100, digits = digits)+ first_row <- tbl[1L, ] |
| 107 | -8x | +546 | +30x |
- left <- paste0(utils::head(percent, -1), "%")+ first_row$time <- 0 |
| 108 | -8x | +547 | +30x |
- right <- paste0(utils::tail(percent, -1), "%")+ first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
|
| 109 | -8x | +548 | +30x |
- without_left_bracket <- paste0(left, ",", right, "]")+ first_row$n.event <- first_row$n.censor <- 0 |
| 110 | -8x | +549 | +30x |
- with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
+ first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1 |
| 111 | -8x | +550 | +30x |
- if (length(without_left_bracket) > 1) {
+ first_row$std.error <- 0 |
| 112 | -6x | +551 | +30x |
- with_left_bracket <- c(+ rbind( |
| 113 | -6x | +552 | +30x |
- with_left_bracket,+ first_row, |
| 114 | -6x | +553 | +30x |
- paste0("(", utils::tail(without_left_bracket, -1))
+ tbl |
| 115 | +554 |
- )+ ) |
||
| 116 | +555 |
- }- |
- ||
| 117 | -8x | -
- with_left_bracket+ } |
||
| 118 | +556 |
- }+ ) |
||
| 119 | -+ | |||
| 557 | +10x |
-
+ y <- do.call(rbind, y_by_strata_extended) |
||
| 120 | +558 |
- #' Cutting Numeric Vector into Empirical Quantile Bins+ |
||
| 121 | -+ | |||
| 559 | +10x |
- #'+ y$censor <- ifelse(y$n.censor > 0, y$estimate, NA) |
||
| 122 | -+ | |||
| 560 | +10x |
- #' @description `r lifecycle::badge("stable")`
+ if (!is.null(max_time)) {
|
||
| 123 | -+ | |||
| 561 | +2x |
- #'+ y <- y[y$time <= max(max_time), ] |
||
| 124 | +562 |
- #' This cuts a numeric vector into sample quantile bins.+ } |
||
| 125 | -+ | |||
| 563 | +10x |
- #'+ y |
||
| 126 | +564 |
- #' @inheritParams bins_percent_labels+ } |
||
| 127 | +565 |
- #' @param x (`numeric`)\cr the continuous variable values which should be cut into+ |
||
| 128 | +566 |
- #' quantile bins. This may contain `NA` values, which are then+ #' Helper function: x tick positions |
||
| 129 | +567 |
- #' not used for the quantile calculations, but included in the return vector.+ #' |
||
| 130 | +568 |
- #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`+ #' @description `r lifecycle::badge("stable")`
|
||
| 131 | +569 |
- #' probabilities in `probs`, then this must be `n + 1` long.+ #' |
||
| 132 | +570 |
- #' @param type (`integer`)\cr type of quantiles to use, see [stats::quantile()] for details.+ #' Calculate the positions of ticks on the x-axis. However, if `xticks` already |
||
| 133 | +571 |
- #' @param ordered (`flag`)\cr should the result be an ordered factor.+ #' exists it is kept as is. It is based on the same function `ggplot2` relies on, |
||
| 134 | +572 |
- #'+ #' and is required in the graphic and the patient-at-risk annotation table. |
||
| 135 | +573 |
- #' @return A `factor` variable with appropriately-labeled bins as levels.+ #' |
||
| 136 | +574 |
- #'+ #' @inheritParams g_km |
||
| 137 | +575 |
- #' @note Intervals are closed on the right side. That is, the first bin is the interval+ #' @inheritParams h_ggkm |
||
| 138 | +576 |
- #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc.,+ #' |
||
| 139 | +577 |
- #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile.+ #' @return A vector of positions to use for x-axis ticks on a `ggplot` object. |
||
| 140 | +578 |
#' |
||
| 141 | +579 |
#' @examples |
||
| 142 | +580 |
- #' # Default is to cut into quartile bins.+ #' \donttest{
|
||
| 143 | +581 |
- #' cut_quantile_bins(cars$speed)+ #' library(dplyr) |
||
| 144 | +582 |
- #'+ #' library(survival) |
||
| 145 | +583 |
- #' # Use custom quantiles.+ #' |
||
| 146 | +584 |
- #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))+ #' data <- tern_ex_adtte %>% |
||
| 147 | +585 |
- #'+ #' filter(PARAMCD == "OS") %>% |
||
| 148 | +586 |
- #' # Use custom labels.+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 149 | +587 |
- #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
+ #' h_data_plot() |
||
| 150 | +588 |
#' |
||
| 151 | +589 |
- #' # NAs are preserved in result factor.+ #' h_xticks(data) |
||
| 152 | +590 |
- #' ozone_binned <- cut_quantile_bins(airquality$Ozone)+ #' h_xticks(data, xticks = seq(0, 3000, 500)) |
||
| 153 | +591 |
- #' which(is.na(ozone_binned))+ #' h_xticks(data, xticks = 500) |
||
| 154 | +592 |
- #' # So you might want to make these explicit.+ #' h_xticks(data, xticks = 500, max_time = 6000) |
||
| 155 | +593 |
- #' explicit_na(ozone_binned)+ #' h_xticks(data, xticks = c(0, 500), max_time = 300) |
||
| 156 | +594 |
- #'+ #' h_xticks(data, xticks = 500, max_time = 300) |
||
| 157 | +595 |
- #' @export+ #' } |
||
| 158 | +596 |
- cut_quantile_bins <- function(x,+ #' |
||
| 159 | +597 |
- probs = c(0.25, 0.5, 0.75),+ #' @export |
||
| 160 | +598 |
- labels = NULL,+ h_xticks <- function(data, xticks = NULL, max_time = NULL) {
|
||
| 161 | -+ | |||
| 599 | +10x |
- type = 7,+ if (is.null(xticks)) {
|
||
| 162 | -+ | |||
| 600 | +4x |
- ordered = TRUE) {
+ if (is.null(max_time)) {
|
||
| 163 | -8x | +601 | +3x |
- checkmate::assert_flag(ordered)+ labeling::extended(range(data$time)[1], range(data$time)[2], m = 5) |
| 164 | -8x | +|||
| 602 | +
- checkmate::assert_numeric(x)+ } else {
|
|||
| 165 | -7x | +603 | +1x |
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5) |
| 166 | -7x | +|||
| 604 | +
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ } |
|||
| 167 | -8x | +605 | +6x |
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ } else if (checkmate::test_number(xticks)) {
|
| 168 | -7x | +606 | +3x |
- if (is.null(labels)) labels <- bins_percent_labels(probs)+ if (is.null(max_time)) {
|
| 169 | -8x | +607 | +2x |
- checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE)+ seq(0, max(data$time), xticks) |
| 170 | +608 |
-
+ } else {
|
||
| 171 | -8x | +609 | +1x |
- if (all(is.na(x))) {
+ seq(0, max(data$time, max_time), xticks) |
| 172 | +610 |
- # Early return if there are only NAs in input.+ } |
||
| 173 | -1x | +611 | +3x |
- return(factor(x, ordered = ordered, levels = labels))+ } else if (is.numeric(xticks)) {
|
| 174 | -+ | |||
| 612 | +2x |
- }+ xticks |
||
| 175 | +613 |
-
+ } else {
|
||
| 176 | -7x | +614 | +1x |
- quantiles <- stats::quantile(+ stop( |
| 177 | -7x | +615 | +1x |
- x,+ paste( |
| 178 | -7x | +616 | +1x |
- probs = probs,+ "xticks should be either `NULL`", |
| 179 | -7x | +617 | +1x |
- type = type,+ "or a single number (interval between x ticks)", |
| 180 | -7x | +618 | +1x |
- na.rm = TRUE+ "or a numeric vector (position of ticks on the x axis)" |
| 181 | +619 |
- )+ ) |
||
| 182 | +620 |
-
+ ) |
||
| 183 | -7x | +|||
| 621 | +
- checkmate::assert_numeric(quantiles, unique = TRUE)+ } |
|||
| 184 | +622 |
-
+ } |
||
| 185 | -6x | +|||
| 623 | +
- cut(+ |
|||
| 186 | -6x | +|||
| 624 | +
- x,+ #' Helper function: KM plot |
|||
| 187 | -6x | +|||
| 625 | +
- breaks = quantiles,+ #' |
|||
| 188 | -6x | +|||
| 626 | +
- labels = labels,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 189 | -6x | +|||
| 627 | +
- ordered_result = ordered,+ #' |
|||
| 190 | -6x | +|||
| 628 | +
- include.lowest = TRUE,+ #' Draw the Kaplan-Meier plot using `ggplot2`. |
|||
| 191 | -6x | +|||
| 629 | +
- right = TRUE+ #' |
|||
| 192 | +630 |
- )+ #' @inheritParams g_km |
||
| 193 | +631 |
- }+ #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`. |
||
| 194 | +632 |
-
+ #' |
||
| 195 | +633 |
- #' Discard Certain Levels from a Factor+ #' @return A `ggplot` object. |
||
| 196 | +634 |
#' |
||
| 197 | +635 |
- #' @description `r lifecycle::badge("stable")`
+ #' @examples |
||
| 198 | +636 |
- #'+ #' \donttest{
|
||
| 199 | +637 |
- #' This discards the observations as well as the levels specified from a factor.+ #' library(dplyr) |
||
| 200 | +638 |
- #'+ #' library(survival) |
||
| 201 | +639 |
- #' @param x (`factor`)\cr the original factor.+ #' |
||
| 202 | +640 |
- #' @param discard (`character`)\cr which levels to discard.+ #' fit_km <- tern_ex_adtte %>% |
||
| 203 | +641 |
- #'+ #' filter(PARAMCD == "OS") %>% |
||
| 204 | +642 |
- #' @return A modified `factor` with observations as well as levels from `discard` dropped.+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 205 | +643 |
- #'+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 206 | +644 |
- #' @examples+ #' xticks <- h_xticks(data = data_plot) |
||
| 207 | +645 |
- #' fct_discard(factor(c("a", "b", "c")), "c")
+ #' gg <- h_ggkm( |
||
| 208 | +646 |
- #'+ #' data = data_plot, |
||
| 209 | +647 |
- #' @export+ #' censor_show = TRUE, |
||
| 210 | +648 |
- fct_discard <- function(x, discard) {
- |
- ||
| 211 | -301x | -
- checkmate::assert_factor(x)+ #' xticks = xticks, |
||
| 212 | -301x | +|||
| 649 | +
- checkmate::assert_character(discard, any.missing = FALSE)+ #' xlab = "Days", |
|||
| 213 | -301x | +|||
| 650 | +
- new_obs <- x[!(x %in% discard)]+ #' yval = "Survival", |
|||
| 214 | -301x | +|||
| 651 | +
- new_levels <- setdiff(levels(x), discard)+ #' ylab = "Survival Probability", |
|||
| 215 | -301x | +|||
| 652 | +
- factor(new_obs, levels = new_levels)+ #' title = "Survival" |
|||
| 216 | +653 |
- }+ #' ) |
||
| 217 | +654 |
-
+ #' gg |
||
| 218 | +655 |
- #' Insertion of Explicit Missings in a Factor+ #' } |
||
| 219 | +656 |
#' |
||
| 220 | +657 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 221 | +658 |
- #'+ h_ggkm <- function(data, |
||
| 222 | +659 |
- #' This inserts explicit missings in a factor based on a condition. Additionally,+ xticks = NULL, |
||
| 223 | +660 |
- #' existing `NA` values will be explicitly converted to given `na_level`.+ yval = "Survival", |
||
| 224 | +661 |
- #'+ censor_show, |
||
| 225 | +662 |
- #' @param x (`factor`)\cr the original factor.+ xlab, |
||
| 226 | +663 |
- #' @param condition (`logical`)\cr where to insert missings.+ ylab, |
||
| 227 | +664 |
- #' @param na_level (`string`)\cr which level to use for missings.+ ylim = NULL, |
||
| 228 | +665 |
- #'+ title, |
||
| 229 | +666 |
- #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`.+ footnotes = NULL, |
||
| 230 | +667 |
- #'+ max_time = NULL, |
||
| 231 | +668 |
- #' @seealso [forcats::fct_na_value_to_level()] which is used internally.+ lwd = 1, |
||
| 232 | +669 |
- #'+ lty = NULL, |
||
| 233 | +670 |
- #' @examples+ pch = 3, |
||
| 234 | +671 |
- #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
+ size = 2, |
||
| 235 | +672 |
- #'+ col = NULL, |
||
| 236 | +673 |
- #' @export+ ci_ribbon = FALSE, |
||
| 237 | +674 |
- fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
+ ggtheme = nestcolor::theme_nest()) {
|
||
| 238 | -1x | +675 | +3x |
- checkmate::assert_factor(x, len = length(condition))+ checkmate::assert_numeric(lty, null.ok = TRUE) |
| 239 | -1x | +676 | +3x |
- checkmate::assert_logical(condition)+ checkmate::assert_character(col, null.ok = TRUE) |
| 240 | -1x | +|||
| 677 | +
- x[condition] <- NA+ |
|||
| 241 | -1x | +678 | +3x |
- x <- forcats::fct_na_value_to_level(x, level = na_level)+ if (is.null(ylim)) {
|
| 242 | +679 | +3x | +
+ data_lims <- data+ |
+ |
| 680 | 1x |
- forcats::fct_drop(x, only = na_level)+ if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]] |
||
| 243 | -+ | |||
| 681 | +3x |
- }+ if (!is.null(max_time)) {
|
||
| 244 | -+ | |||
| 682 | +! |
-
+ y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]]) |
||
| 245 | -+ | |||
| 683 | +! |
- #' Collapsing of Factor Levels and Keeping Only Those New Group Levels+ y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]]) |
||
| 246 | +684 |
- #'+ } else {
|
||
| 247 | -+ | |||
| 685 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ y_lwr <- min(data_lims[["estimate"]]) |
||
| 248 | -+ | |||
| 686 | +3x |
- #'+ y_upr <- max(data_lims[["estimate"]]) |
||
| 249 | +687 |
- #' This collapses levels and only keeps those new group levels, in the order provided.+ } |
||
| 250 | -+ | |||
| 688 | +3x |
- #' The returned factor has levels in the order given, with the possible missing level last (this will+ ylim <- c(y_lwr, y_upr) |
||
| 251 | +689 |
- #' only be included if there are missing values).+ } |
||
| 252 | -+ | |||
| 690 | +3x |
- #'+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE) |
||
| 253 | +691 |
- #' @param .f (`factor` or `character`)\cr original vector.+ |
||
| 254 | +692 |
- #' @param ... (named `character` vectors)\cr levels in each vector provided will be collapsed into+ # change estimates of survival to estimates of failure (1 - survival) |
||
| 255 | -+ | |||
| 693 | +3x |
- #' the new level given by the respective name.+ if (yval == "Failure") {
|
||
| 256 | -+ | |||
| 694 | +1x |
- #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the+ data$estimate <- 1 - data$estimate |
||
| 257 | -+ | |||
| 695 | +1x |
- #' new factor. Note that this level must not be contained in the new levels specified in `...`.+ data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
|
||
| 258 | -+ | |||
| 696 | +1x |
- #'+ data$censor <- 1 - data$censor |
||
| 259 | +697 |
- #' @return A modified `factor` with collapsed levels. Values and levels which are not included+ } |
||
| 260 | +698 |
- #' in the given `character` vector input will be set to the missing level `.na_level`.+ |
||
| 261 | -+ | |||
| 699 | +3x |
- #'+ gg <- {
|
||
| 262 | -+ | |||
| 700 | +3x |
- #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed,+ ggplot2::ggplot( |
||
| 263 | -+ | |||
| 701 | +3x |
- #' [explicit_na()] can be called separately on the result.+ data = data, |
||
| 264 | -+ | |||
| 702 | +3x |
- #'+ mapping = ggplot2::aes( |
||
| 265 | -+ | |||
| 703 | +3x |
- #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.+ x = .data[["time"]],+ |
+ ||
| 704 | +3x | +
+ y = .data[["estimate"]],+ |
+ ||
| 705 | +3x | +
+ ymin = .data[["conf.low"]],+ |
+ ||
| 706 | +3x | +
+ ymax = .data[["conf.high"]],+ |
+ ||
| 707 | +3x | +
+ color = .data[["strata"]],+ |
+ ||
| 708 | +3x | +
+ fill = .data[["strata"]] |
||
| 266 | +709 |
- #'+ ) |
||
| 267 | +710 |
- #' @examples+ ) ++ |
+ ||
| 711 | +3x | +
+ ggplot2::geom_hline(yintercept = 0) |
||
| 268 | +712 |
- #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
+ } |
||
| 269 | +713 |
- #'+ + |
+ ||
| 714 | +3x | +
+ if (ci_ribbon) {
+ |
+ ||
| 715 | +! | +
+ gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0) |
||
| 270 | +716 |
- #' @export+ } |
||
| 271 | +717 |
- fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
+
|
||
| 272 | -4x | +718 | +3x |
- new_lvls <- names(list(...))+ gg <- if (is.null(lty)) {
|
| 273 | -4x | +719 | +2x |
- if (checkmate::test_subset(.na_level, new_lvls)) {
+ gg + |
| 274 | +720 | +2x | +
+ ggplot2::geom_step(linewidth = lwd)+ |
+ |
| 721 | +3x | +
+ } else if (checkmate::test_number(lty)) {
+ |
+ ||
| 722 | 1x |
- stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
+ gg ++ |
+ ||
| 723 | +1x | +
+ ggplot2::geom_step(linewidth = lwd, lty = lty)+ |
+ ||
| 724 | +3x | +
+ } else if (is.numeric(lty)) {
+ |
+ ||
| 725 | +! | +
+ gg ++ |
+ ||
| 726 | +! | +
+ ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ |
+ ||
| 727 | +! | +
+ ggplot2::scale_linetype_manual(values = lty) |
||
| 275 | +728 |
} |
||
| 729 | ++ | + + | +||
| 276 | +730 | 3x |
- x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ gg <- gg + |
|
| 277 | +731 | 3x |
- do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))+ ggplot2::coord_cartesian(ylim = ylim) + |
|
| 278 | -+ | |||
| 732 | +3x |
- }+ ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes) |
||
| 279 | +733 | |||
| 280 | -+ | |||
| 734 | +3x |
- #' Ungroup Non-Numeric Statistics+ if (!is.null(col)) {
|
||
| 281 | -+ | |||
| 735 | +! |
- #'+ gg <- gg + |
||
| 282 | -+ | |||
| 736 | +! |
- #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`.+ ggplot2::scale_color_manual(values = col) + |
||
| 283 | -+ | |||
| 737 | +! |
- #'+ ggplot2::scale_fill_manual(values = col) |
||
| 284 | +738 |
- #' @inheritParams argument_convention+ } |
||
| 285 | -+ | |||
| 739 | +3x |
- #' @param x (`named list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup.+ if (censor_show) {
|
||
| 286 | -+ | |||
| 740 | +3x |
- #'+ dt <- data[data$n.censor != 0, ] |
||
| 287 | -+ | |||
| 741 | +3x |
- #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`.+ dt$censor_lbl <- factor("Censored")
|
||
| 288 | +742 |
- #'+ |
||
| 289 | -+ | |||
| 743 | +3x |
- #' @seealso [a_summary()] which uses this function internally.+ gg <- gg + ggplot2::geom_point( |
||
| 290 | -+ | |||
| 744 | +3x |
- #'+ data = dt, |
||
| 291 | -+ | |||
| 745 | +3x |
- #' @keywords internal+ ggplot2::aes( |
||
| 292 | -+ | |||
| 746 | +3x |
- ungroup_stats <- function(x,+ x = .data[["time"]], |
||
| 293 | -+ | |||
| 747 | +3x |
- .formats,+ y = .data[["censor"]],+ |
+ ||
| 748 | +3x | +
+ shape = .data[["censor_lbl"]] |
||
| 294 | +749 |
- .labels,+ ),+ |
+ ||
| 750 | +3x | +
+ size = size,+ |
+ ||
| 751 | +3x | +
+ show.legend = TRUE,+ |
+ ||
| 752 | +3x | +
+ inherit.aes = TRUE |
||
| 295 | +753 |
- .indent_mods) {
+ ) + |
||
| 296 | -276x | +754 | +3x |
- checkmate::assert_list(x)+ ggplot2::scale_shape_manual(name = NULL, values = pch) + |
| 297 | -276x | +755 | +3x |
- empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0+ ggplot2::guides( |
| 298 | -276x | +756 | +3x |
- empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0+ shape = ggplot2::guide_legend(override.aes = list(linetype = NA)), |
| 299 | -276x | +757 | +3x |
- x <- unlist(x, recursive = FALSE)+ fill = ggplot2::guide_legend(override.aes = list(shape = NA)) |
| 300 | +758 |
-
+ ) |
||
| 301 | +759 |
- # If p-value is empty it is removed by unlist and needs to be re-added+ }+ |
+ ||
| 760 | ++ | + + | +||
| 761 | +3x | +
+ if (!is.null(max_time) && !is.null(xticks)) {
|
||
| 302 | +762 | ! |
- if (empty_pval) x[["pval"]] <- character()+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time)))) |
|
| 303 | +763 | 3x |
- if (empty_pval_counts) x[["pval_counts"]] <- character()+ } else if (!is.null(xticks)) {
|
|
| 304 | -276x | +764 | +3x |
- .stats <- names(x)+ if (max(data$time) <= max(xticks)) {
|
| 305 | -+ | |||
| 765 | +2x |
-
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks))) |
||
| 306 | +766 |
- # Ungroup stats+ } else {
|
||
| 307 | -276x | +767 | +1x |
- .formats <- lapply(.stats, function(x) {
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks) |
| 308 | -2273x | +|||
| 768 | +
- .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ } |
|||
| 309 | -+ | |||
| 769 | +! |
- })+ } else if (!is.null(max_time)) {
|
||
| 310 | -276x | +|||
| 770 | +! |
- .indent_mods <- sapply(.stats, function(x) {
+ gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time)) |
||
| 311 | -2273x | +|||
| 771 | +
- .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ } |
|||
| 312 | +772 |
- })+ |
||
| 313 | -276x | +773 | +3x |
- .labels <- sapply(.stats, function(x) {
+ if (!is.null(ggtheme)) {
|
| 314 | -2216x | +774 | +3x |
- if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
+ gg <- gg + ggtheme |
| 315 | +775 |
- })+ } |
||
| 316 | +776 | |||
| 317 | -276x | +777 | +3x |
- list(+ gg + ggplot2::theme( |
| 318 | -276x | +778 | +3x |
- x = x,+ legend.position = "bottom", |
| 319 | -276x | +779 | +3x |
- .formats = .formats,+ legend.title = ggplot2::element_blank(), |
| 320 | -276x | +780 | +3x |
- .labels = .labels,+ legend.key.height = unit(0.02, "npc"), |
| 321 | -276x | +781 | +3x |
- .indent_mods = .indent_mods+ panel.grid.major.x = ggplot2::element_line(linewidth = 2) |
| 322 | +782 |
) |
||
| 323 | +783 |
} |
| 1 | -- |
- #' Helper Functions for Multivariate Logistic Regression- |
- ||
| 2 | +784 |
- #'+ |
||
| 3 | +785 |
- #' @description `r lifecycle::badge("stable")`
+ #' `ggplot` Decomposition |
||
| 4 | +786 |
#' |
||
| 5 | +787 |
- #' Helper functions used in calculations for logistic regression.+ #' @description `r lifecycle::badge("stable")`
|
||
| 6 | +788 |
#' |
||
| 7 | +789 |
- #' @inheritParams argument_convention+ #' The elements composing the `ggplot` are extracted and organized in a `list`. |
||
| 8 | +790 |
- #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.+ #' |
||
| 9 | +791 |
- #' Limited functionality is also available for conditional logistic regression models fitted by+ #' @param gg (`ggplot`)\cr a graphic to decompose. |
||
| 10 | +792 |
- #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()].+ #' |
||
| 11 | +793 |
- #' @param x (`string` or `character`)\cr a variable or interaction term in `fit_glm` (depending on the+ #' @return A named `list` with elements: |
||
| 12 | +794 |
- #' helper function).+ #' * `panel`: The panel. |
||
| 13 | +795 |
- #'+ #' * `yaxis`: The y-axis. |
||
| 14 | +796 |
- #' @examples+ #' * `xaxis`: The x-axis. |
||
| 15 | +797 |
- #' library(dplyr)+ #' * `xlab`: The x-axis label. |
||
| 16 | +798 |
- #' library(broom)+ #' * `ylab`: The y-axis label. |
||
| 17 | +799 |
- #'+ #' * `guide`: The legend. |
||
| 18 | +800 |
- #' adrs_f <- tern_ex_adrs %>%+ #' |
||
| 19 | +801 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' @examples |
||
| 20 | +802 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' \donttest{
|
||
| 21 | +803 |
- #' mutate(+ #' library(dplyr) |
||
| 22 | +804 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' library(survival) |
||
| 23 | +805 |
- #' RACE = factor(RACE),+ #' library(grid) |
||
| 24 | +806 |
- #' SEX = factor(SEX)+ #' |
||
| 25 | +807 |
- #' )+ #' fit_km <- tern_ex_adtte %>% |
||
| 26 | +808 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ #' filter(PARAMCD == "OS") %>% |
||
| 27 | +809 |
- #' mod1 <- fit_logistic(+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 28 | +810 |
- #' data = adrs_f,+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 29 | +811 |
- #' variables = list(+ #' xticks <- h_xticks(data = data_plot) |
||
| 30 | +812 |
- #' response = "Response",+ #' gg <- h_ggkm( |
||
| 31 | +813 |
- #' arm = "ARMCD",+ #' data = data_plot, |
||
| 32 | +814 |
- #' covariates = c("AGE", "RACE")
+ #' yval = "Survival", |
||
| 33 | +815 |
- #' )+ #' censor_show = TRUE, |
||
| 34 | +816 |
- #' )+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 35 | +817 |
- #' mod2 <- fit_logistic(+ #' title = "tt", |
||
| 36 | +818 |
- #' data = adrs_f,+ #' footnotes = "ff" |
||
| 37 | +819 |
- #' variables = list(+ #' ) |
||
| 38 | +820 |
- #' response = "Response",+ #' |
||
| 39 | +821 |
- #' arm = "ARMCD",+ #' g_el <- h_decompose_gg(gg) |
||
| 40 | +822 |
- #' covariates = c("AGE", "RACE"),
+ #' grid::grid.newpage() |
||
| 41 | +823 |
- #' interaction = "AGE"+ #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5)) |
||
| 42 | +824 |
- #' )+ #' grid::grid.draw(g_el$panel) |
||
| 43 | +825 |
- #' )+ #' |
||
| 44 | +826 |
- #'+ #' grid::grid.newpage() |
||
| 45 | +827 |
- #' @name h_logistic_regression+ #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5)) |
||
| 46 | +828 |
- NULL+ #' grid::grid.draw(with(g_el, cbind(ylab, yaxis))) |
||
| 47 | +829 |
-
+ #' } |
||
| 48 | +830 |
- #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted+ #' |
||
| 49 | +831 |
- #' model assuming only one interaction term.+ #' @export |
||
| 50 | +832 |
- #'+ h_decompose_gg <- function(gg) {
|
||
| 51 | -+ | |||
| 833 | +3x |
- #' @return Vector of names of interaction variables.+ g_el <- ggplot2::ggplotGrob(gg) |
||
| 52 | -+ | |||
| 834 | +3x |
- #'+ y <- c( |
||
| 53 | -+ | |||
| 835 | +3x |
- #' @export+ panel = "panel", |
||
| 54 | -+ | |||
| 836 | +3x |
- h_get_interaction_vars <- function(fit_glm) {
+ yaxis = "axis-l", |
||
| 55 | -27x | +837 | +3x |
- checkmate::assert_class(fit_glm, "glm")+ xaxis = "axis-b", |
| 56 | -27x | +838 | +3x |
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ xlab = "xlab-b", |
| 57 | -27x | +839 | +3x |
- terms_order <- attr(stats::terms(fit_glm), "order")+ ylab = "ylab-l", |
| 58 | -27x | +840 | +3x |
- interaction_term <- terms_name[terms_order == 2]+ guide = "guide" |
| 59 | -27x | +|||
| 841 | +
- checkmate::assert_string(interaction_term)+ ) |
|||
| 60 | -27x | +842 | +3x |
- strsplit(interaction_term, split = ":")[[1]]+ lapply(X = y, function(x) gtable::gtable_filter(g_el, x)) |
| 61 | +843 |
} |
||
| 62 | +844 | |||
| 63 | +845 |
- #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the+ #' Helper: KM Layout |
||
| 64 | +846 |
- #' interaction variable names and the given levels. The main value here is that the order+ #' |
||
| 65 | +847 |
- #' of first and second variable is checked in the `interaction_vars` input.+ #' @description `r lifecycle::badge("stable")`
|
||
| 66 | +848 |
#' |
||
| 67 | +849 |
- #' @param interaction_vars (`character` of length 2)\cr interaction variable names.+ #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve. |
||
| 68 | +850 |
- #' @param first_var_with_level (`character` of length 2)\cr the first variable name with+ #' |
||
| 69 | +851 |
- #' the interaction level.+ #' @inheritParams g_km |
||
| 70 | +852 |
- #' @param second_var_with_level (`character` of length 2)\cr the second variable name with+ #' @inheritParams h_ggkm |
||
| 71 | +853 |
- #' the interaction level.+ #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`. |
||
| 72 | +854 |
- #'+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of |
||
| 73 | +855 |
- #' @return Name of coefficient.+ #' patient at risk matching the main grid of the Kaplan-Meier curve. |
||
| 74 | +856 |
#' |
||
| 75 | +857 |
- #' @export+ #' @return A grid layout. |
||
| 76 | +858 |
- h_interaction_coef_name <- function(interaction_vars,+ #' |
||
| 77 | +859 |
- first_var_with_level,+ #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the |
||
| 78 | +860 |
- second_var_with_level) {
+ #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space. |
||
| 79 | -45x | +|||
| 861 | +
- checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)+ #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient |
|||
| 80 | -45x | +|||
| 862 | +
- checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)+ #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of |
|||
| 81 | -45x | +|||
| 863 | +
- checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)+ #' the strata name. |
|||
| 82 | -45x | +|||
| 864 | +
- checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)+ #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table. |
|||
| 83 | +865 |
-
+ #' |
||
| 84 | -45x | -
- first_name <- paste(first_var_with_level, collapse = "")+ | ||
| 866 | ++ |
+ #' @examples |
||
| 85 | -45x | +|||
| 867 | +
- second_name <- paste(second_var_with_level, collapse = "")+ #' \donttest{
|
|||
| 86 | -45x | +|||
| 868 | +
- if (first_var_with_level[1] == interaction_vars[1]) {
+ #' library(dplyr) |
|||
| 87 | -34x | +|||
| 869 | +
- paste(first_name, second_name, sep = ":")+ #' library(survival) |
|||
| 88 | -11x | +|||
| 870 | +
- } else if (second_var_with_level[1] == interaction_vars[1]) {
+ #' library(grid) |
|||
| 89 | -11x | +|||
| 871 | +
- paste(second_name, first_name, sep = ":")+ #' |
|||
| 90 | +872 |
- }+ #' fit_km <- tern_ex_adtte %>% |
||
| 91 | +873 |
- }+ #' filter(PARAMCD == "OS") %>% |
||
| 92 | +874 |
-
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 93 | +875 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 94 | +876 |
- #' for the case when both the odds ratio and the interaction variable are categorical.+ #' xticks <- h_xticks(data = data_plot) |
||
| 95 | +877 |
- #'+ #' gg <- h_ggkm( |
||
| 96 | +878 |
- #' @param odds_ratio_var (`string`)\cr the odds ratio variable.+ #' data = data_plot, |
||
| 97 | +879 |
- #' @param interaction_var (`string`)\cr the interaction variable.+ #' censor_show = TRUE, |
||
| 98 | +880 |
- #'+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 99 | +881 |
- #' @return Odds ratio.+ #' title = "tt", footnotes = "ff", yval = "Survival" |
||
| 100 | +882 |
- #'+ #' ) |
||
| 101 | +883 |
- #' @export+ #' g_el <- h_decompose_gg(gg) |
||
| 102 | +884 |
- h_or_cat_interaction <- function(odds_ratio_var,+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
||
| 103 | +885 |
- interaction_var,+ #' grid.show.layout(lyt) |
||
| 104 | +886 |
- fit_glm,+ #' } |
||
| 105 | +887 |
- conf_level = 0.95) {
+ #' |
||
| 106 | -7x | +|||
| 888 | +
- interaction_vars <- h_get_interaction_vars(fit_glm)+ #' @export |
|||
| 107 | -7x | +|||
| 889 | +
- checkmate::assert_string(odds_ratio_var)+ h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
|
|||
| 108 | -7x | +890 | +2x |
- checkmate::assert_string(interaction_var)+ txtlines <- levels(as.factor(data$strata)) |
| 109 | -7x | +891 | +2x |
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ nlines <- nlevels(as.factor(data$strata)) |
| 110 | -7x | +892 | +2x |
- checkmate::assert_vector(interaction_vars, len = 2)+ col_annot_width <- max( |
| 111 | -+ | |||
| 893 | +2x |
-
+ c( |
||
| 112 | -7x | +894 | +2x |
- xs_level <- fit_glm$xlevels+ as.numeric(grid::convertX(g_el$yaxis$width + g_el$ylab$width, "pt")), |
| 113 | -7x | +895 | +2x |
- xs_coef <- stats::coef(fit_glm)+ as.numeric( |
| 114 | -7x | +896 | +2x |
- xs_vcov <- stats::vcov(fit_glm)+ grid::convertX( |
| 115 | -7x | +897 | +2x |
- y <- list()+ grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt" |
| 116 | -7x | +|||
| 898 | +
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ ) |
|||
| 117 | -12x | +|||
| 899 | +
- x <- list()+ ) |
|||
| 118 | -12x | +|||
| 900 | +
- for (ref_level in xs_level[[interaction_var]]) {
+ ) |
|||
| 119 | -32x | +|||
| 901 | +
- coef_names <- paste0(odds_ratio_var, var_level)+ )+ |
+ |||
| 902 | ++ | + | ||
| 120 | -32x | +903 | +2x |
- if (ref_level != xs_level[[interaction_var]][1]) {
+ ttl_row <- as.numeric(!is.null(title)) |
| 121 | -20x | +904 | +2x |
- interaction_coef_name <- h_interaction_coef_name(+ foot_row <- as.numeric(!is.null(footnotes)) |
| 122 | -20x | +905 | +2x |
- interaction_vars,+ no_tbl_ind <- c() |
| 123 | -20x | +906 | +2x |
- c(odds_ratio_var, var_level),+ ht_x <- c() |
| 124 | -20x | +907 | +2x |
- c(interaction_var, ref_level)+ ht_units <- c() |
| 125 | +908 |
- )+ |
||
| 126 | -20x | +909 | +2x |
- coef_names <- c(+ if (ttl_row == 1) {
|
| 127 | -20x | +910 | +1x |
- coef_names,+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
| 128 | -20x | +911 | +1x |
- interaction_coef_name+ ht_x <- c(ht_x, 2)+ |
+
| 912 | +1x | +
+ ht_units <- c(ht_units, "lines") |
||
| 129 | +913 |
- )+ } |
||
| 130 | +914 |
- }+ |
||
| 131 | -32x | +915 | +2x |
- if (length(coef_names) > 1) {
+ no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2)) |
| 132 | -20x | +916 | +2x |
- ones <- t(c(1, 1))+ ht_x <- c( |
| 133 | -20x | +917 | +2x |
- est <- as.numeric(ones %*% xs_coef[coef_names])+ ht_x, |
| 134 | -20x | +918 | +2x |
- se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))+ 1, |
| 135 | -+ | |||
| 919 | +2x |
- } else {
+ grid::convertX(with(g_el, xaxis$height + ylab$width), "pt") + grid::unit(5, "pt"), |
||
| 136 | -12x | +920 | +2x |
- est <- xs_coef[coef_names]+ grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"), |
| 137 | -12x | +921 | +2x |
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ 1, |
| 138 | -+ | |||
| 922 | +2x |
- }+ nlines + 0.5, |
||
| 139 | -32x | +923 | +2x |
- or <- exp(est)+ grid::convertX(with(g_el, xaxis$height + ylab$width), "pt") |
| 140 | -32x | +|||
| 924 | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ ) |
|||
| 141 | -32x | +925 | +2x |
- x[[ref_level]] <- list(or = or, ci = ci)+ ht_units <- c( |
| 142 | -+ | |||
| 926 | +2x |
- }+ ht_units, |
||
| 143 | -12x | +927 | +2x |
- y[[var_level]] <- x+ "null", |
| 144 | -+ | |||
| 928 | +2x |
- }+ "pt", |
||
| 145 | -7x | +929 | +2x |
- y+ "pt", |
| 146 | -+ | |||
| 930 | +2x |
- }+ "lines", |
||
| 147 | -+ | |||
| 931 | +2x |
-
+ "lines", |
||
| 148 | -+ | |||
| 932 | +2x |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ "pt" |
||
| 149 | +933 |
- #' for the case when either the odds ratio or the interaction variable is continuous.+ ) |
||
| 150 | +934 |
- #'+ |
||
| 151 | -+ | |||
| 935 | +2x |
- #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise+ if (foot_row == 1) {
|
||
| 152 | -+ | |||
| 936 | +1x |
- #' the median is used.+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
||
| 153 | -+ | |||
| 937 | +1x |
- #'+ ht_x <- c(ht_x, 1) |
||
| 154 | -+ | |||
| 938 | +1x |
- #' @return Odds ratio.+ ht_units <- c(ht_units, "lines") |
||
| 155 | +939 |
- #'+ } |
||
| 156 | -+ | |||
| 940 | +2x |
- #' @note We don't provide a function for the case when both variables are continuous because+ if (annot_at_risk) {
|
||
| 157 | -+ | |||
| 941 | +2x |
- #' this does not arise in this table, as the treatment arm variable will always be involved+ no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row) |
||
| 158 | -+ | |||
| 942 | +2x |
- #' and categorical.+ if (!annot_at_risk_title) {
|
||
| 159 | -+ | |||
| 943 | +! |
- #'+ no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE |
||
| 160 | +944 |
- #' @export+ } |
||
| 161 | +945 |
- h_or_cont_interaction <- function(odds_ratio_var,+ } else {
|
||
| 162 | -+ | |||
| 946 | +! |
- interaction_var,+ no_at_risk_tbl <- no_tbl_ind |
||
| 163 | +947 |
- fit_glm,+ } |
||
| 164 | +948 |
- at = NULL,+ |
||
| 165 | -+ | |||
| 949 | +2x |
- conf_level = 0.95) {
+ grid::grid.layout( |
||
| 166 | -9x | +950 | +2x |
- interaction_vars <- h_get_interaction_vars(fit_glm)+ nrow = sum(no_at_risk_tbl), ncol = 2, |
| 167 | -9x | +951 | +2x |
- checkmate::assert_string(odds_ratio_var)+ widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
|
| 168 | -9x | +952 | +2x |
- checkmate::assert_string(interaction_var)+ heights = grid::unit( |
| 169 | -9x | +953 | +2x |
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ x = ht_x[no_at_risk_tbl], |
| 170 | -9x | +954 | +2x |
- checkmate::assert_vector(interaction_vars, len = 2)+ units = ht_units[no_at_risk_tbl] |
| 171 | -9x | +|||
| 955 | +
- checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ ) |
|||
| 172 | -9x | +|||
| 956 | +
- xs_level <- fit_glm$xlevels+ ) |
|||
| 173 | -9x | +|||
| 957 | +
- xs_coef <- stats::coef(fit_glm)+ } |
|||
| 174 | -9x | +|||
| 958 | +
- xs_vcov <- stats::vcov(fit_glm)+ |
|||
| 175 | -9x | +|||
| 959 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ #' Helper: Patient-at-Risk Grobs |
|||
| 176 | -9x | +|||
| 960 | +
- model_data <- fit_glm$model+ #' |
|||
| 177 | -9x | +|||
| 961 | +
- if (!is.null(at)) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 178 | -2x | +|||
| 962 | +
- checkmate::assert_set_equal(xs_class[interaction_var], "numeric")+ #' |
|||
| 179 | +963 |
- }+ #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of |
||
| 180 | -9x | +|||
| 964 | +
- y <- list()+ #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is |
|||
| 181 | -9x | +|||
| 965 | +
- if (xs_class[interaction_var] == "numeric") {
+ #' also obtained. |
|||
| 182 | -6x | +|||
| 966 | +
- if (is.null(at)) {
+ #' |
|||
| 183 | -4x | +|||
| 967 | +
- at <- ceiling(stats::median(model_data[[interaction_var]]))+ #' @inheritParams g_km |
|||
| 184 | +968 |
- }+ #' @inheritParams h_ggkm |
||
| 185 | +969 |
-
+ #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which |
||
| 186 | -6x | +|||
| 970 | +
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ #' includes the number of patients at risk at given time points. |
|||
| 187 | -12x | +|||
| 971 | +
- x <- list()+ #' @param xlim (`numeric`)\cr the maximum value on the x-axis (used to |
|||
| 188 | -12x | +|||
| 972 | +
- for (increment in at) {
+ #' ensure the at risk table aligns with the KM graph). |
|||
| 189 | -18x | +|||
| 973 | +
- coef_names <- paste0(odds_ratio_var, var_level)+ #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
|||
| 190 | -18x | +|||
| 974 | +
- if (increment != 0) {
+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
|||
| 191 | -18x | +|||
| 975 | +
- interaction_coef_name <- h_interaction_coef_name(+ #' |
|||
| 192 | -18x | +|||
| 976 | +
- interaction_vars,+ #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three |
|||
| 193 | -18x | +|||
| 977 | +
- c(odds_ratio_var, var_level),+ #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`. |
|||
| 194 | -18x | +|||
| 978 | +
- c(interaction_var, "")+ #' |
|||
| 195 | +979 |
- )+ #' @examples |
||
| 196 | -18x | +|||
| 980 | +
- coef_names <- c(+ #' \donttest{
|
|||
| 197 | -18x | +|||
| 981 | +
- coef_names,+ #' library(dplyr) |
|||
| 198 | -18x | +|||
| 982 | +
- interaction_coef_name+ #' library(survival) |
|||
| 199 | +983 |
- )+ #' library(grid) |
||
| 200 | +984 |
- }+ #' |
||
| 201 | -18x | +|||
| 985 | +
- if (length(coef_names) > 1) {
+ #' fit_km <- tern_ex_adtte %>% |
|||
| 202 | -18x | +|||
| 986 | +
- xvec <- t(c(1, increment))+ #' filter(PARAMCD == "OS") %>% |
|||
| 203 | -18x | +|||
| 987 | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 204 | -18x | +|||
| 988 | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ #' |
|||
| 205 | +989 |
- } else {
+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 206 | -! | +|||
| 990 | +
- est <- xs_coef[coef_names]+ #' |
|||
| 207 | -! | +|||
| 991 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' xticks <- h_xticks(data = data_plot) |
|||
| 208 | +992 |
- }+ #' |
||
| 209 | -18x | +|||
| 993 | +
- or <- exp(est)+ #' gg <- h_ggkm( |
|||
| 210 | -18x | +|||
| 994 | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ #' data = data_plot, |
|||
| 211 | -18x | +|||
| 995 | +
- x[[as.character(increment)]] <- list(or = or, ci = ci)+ #' censor_show = TRUE, |
|||
| 212 | +996 |
- }+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 213 | -12x | +|||
| 997 | +
- y[[var_level]] <- x+ #' title = "tt", footnotes = "ff", yval = "Survival" |
|||
| 214 | +998 |
- }+ #' ) |
||
| 215 | +999 |
- } else {
+ #' |
||
| 216 | -3x | +|||
| 1000 | +
- checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")+ #' # The annotation table reports the patient at risk for a given strata and |
|||
| 217 | -3x | +|||
| 1001 | +
- checkmate::assert_set_equal(xs_class[interaction_var], "factor")+ #' # time (`xticks`). |
|||
| 218 | -3x | +|||
| 1002 | +
- for (var_level in xs_level[[interaction_var]]) {
+ #' annot_tbl <- summary(fit_km, time = xticks) |
|||
| 219 | -9x | +|||
| 1003 | +
- coef_names <- odds_ratio_var+ #' if (is.null(fit_km$strata)) {
|
|||
| 220 | -9x | +|||
| 1004 | +
- if (var_level != xs_level[[interaction_var]][1]) {
+ #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All")) |
|||
| 221 | -6x | +|||
| 1005 | +
- interaction_coef_name <- h_interaction_coef_name(+ #' } else {
|
|||
| 222 | -6x | +|||
| 1006 | +
- interaction_vars,+ #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
|||
| 223 | -6x | +|||
| 1007 | +
- c(odds_ratio_var, ""),+ #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
|||
| 224 | -6x | +|||
| 1008 | +
- c(interaction_var, var_level)+ #' annot_tbl <- data.frame( |
|||
| 225 | +1009 |
- )+ #' n.risk = annot_tbl$n.risk, |
||
| 226 | -6x | +|||
| 1010 | +
- coef_names <- c(+ #' time = annot_tbl$time, |
|||
| 227 | -6x | +|||
| 1011 | +
- coef_names,+ #' strata = annot_tbl$strata |
|||
| 228 | -6x | +|||
| 1012 | +
- interaction_coef_name+ #' ) |
|||
| 229 | +1013 |
- )+ #' } |
||
| 230 | +1014 |
- }+ #' |
||
| 231 | -9x | +|||
| 1015 | +
- if (length(coef_names) > 1) {
+ #' # The annotation table is transformed into a grob. |
|||
| 232 | -6x | +|||
| 1016 | +
- xvec <- t(c(1, 1))+ #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks)) |
|||
| 233 | -6x | +|||
| 1017 | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ #' |
|||
| 234 | -6x | +|||
| 1018 | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ #' # For the representation, the layout is estimated for which the decomposition |
|||
| 235 | +1019 |
- } else {
+ #' # of the graphic element is necessary. |
||
| 236 | -3x | +|||
| 1020 | +
- est <- xs_coef[coef_names]+ #' g_el <- h_decompose_gg(gg) |
|||
| 237 | -3x | +|||
| 1021 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
|||
| 238 | +1022 |
- }- |
- ||
| 239 | -9x | -
- or <- exp(est)- |
- ||
| 240 | -9x | -
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)- |
- ||
| 241 | -9x | -
- y[[var_level]] <- list(or = or, ci = ci)+ #' |
||
| 242 | +1023 |
- }+ #' grid::grid.newpage() |
||
| 243 | +1024 |
- }- |
- ||
| 244 | -9x | -
- y+ #' pushViewport(viewport(layout = lyt, height = .95, width = .95)) |
||
| 245 | +1025 |
- }+ #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1)) |
||
| 246 | +1026 |
-
+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2)) |
||
| 247 | +1027 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1)) |
||
| 248 | +1028 |
- #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and+ #' grid::grid.draw(tbl$at_risk) |
||
| 249 | +1029 |
- #' [h_or_cat_interaction()].+ #' popViewport() |
||
| 250 | +1030 |
- #'+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1)) |
||
| 251 | +1031 |
- #' @return Odds ratio.+ #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1)) |
||
| 252 | +1032 |
- #'+ #' grid::grid.draw(tbl$label) |
||
| 253 | +1033 |
- #' @export+ #' } |
||
| 254 | +1034 |
- h_or_interaction <- function(odds_ratio_var,+ #' |
||
| 255 | +1035 |
- interaction_var,+ #' @export |
||
| 256 | +1036 |
- fit_glm,+ h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
|
||
| 257 | -+ | |||
| 1037 | +2x |
- at = NULL,+ txtlines <- levels(as.factor(data$strata)) |
||
| 258 | -+ | |||
| 1038 | +2x |
- conf_level = 0.95) {
+ nlines <- nlevels(as.factor(data$strata)) |
||
| 259 | -13x | +1039 | +2x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ y_int <- annot_tbl$time[2] - annot_tbl$time[1] |
| 260 | -13x | +1040 | +2x |
- if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
+ annot_tbl <- expand.grid( |
| 261 | -7x | +1041 | +2x |
- h_or_cont_interaction(+ time = seq(0, xlim, y_int), |
| 262 | -7x | +1042 | +2x |
- odds_ratio_var,+ strata = unique(annot_tbl$strata) |
| 263 | -7x | +1043 | +2x |
- interaction_var,+ ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
|
| 264 | -7x | +1044 | +2x |
- fit_glm,+ annot_tbl[is.na(annot_tbl)] <- 0 |
| 265 | -7x | +1045 | +2x |
- at = at,+ y_str_unit <- as.numeric(annot_tbl$strata) |
| 266 | -7x | +1046 | +2x |
- conf_level = conf_level+ vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines")) |
| 267 | -+ | |||
| 1047 | +2x |
- )+ if (title) {
|
||
| 268 | -6x | +1048 | +2x |
- } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ gb_table_title <- grid::gList( |
| 269 | -6x | +1049 | +2x |
- h_or_cat_interaction(+ grid::textGrob( |
| 270 | -6x | +1050 | +2x |
- odds_ratio_var,+ label = "Patients at Risk:", |
| 271 | -6x | +1051 | +2x |
- interaction_var,+ x = 1, |
| 272 | -6x | +1052 | +2x |
- fit_glm,+ y = grid::unit(0.2, "native"), |
| 273 | -6x | +1053 | +2x |
- conf_level = conf_level+ gp = grid::gpar(fontface = "bold", fontsize = 10) |
| 274 | +1054 |
- )+ ) |
||
| 275 | +1055 |
- } else {
- |
- ||
| 276 | -! | -
- stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
+ ) |
||
| 277 | +1056 |
} |
||
| 278 | -+ | |||
| 1057 | +2x |
- }+ gb_table_left_annot <- grid::gList( |
||
| 279 | -+ | |||
| 1058 | +2x |
-
+ grid::rectGrob( |
||
| 280 | -+ | |||
| 1059 | +2x |
- #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
||
| 281 | -+ | |||
| 1060 | +2x |
- #' of numbers of patients.+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
|
||
| 282 | -+ | |||
| 1061 | +2x |
- #'+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
||
| 283 | +1062 |
- #' @param terms (`character`)\cr simple terms.+ ), |
||
| 284 | -+ | |||
| 1063 | +2x |
- #' @param table (`table`)\cr table containing numbers for terms.+ grid::textGrob( |
||
| 285 | -+ | |||
| 1064 | +2x |
- #'+ label = unique(annot_tbl$strata), |
||
| 286 | -+ | |||
| 1065 | +2x |
- #' @return Term labels containing numbers of patients.+ x = 0.5, |
||
| 287 | -+ | |||
| 1066 | +2x |
- #'+ y = grid::unit( |
||
| 288 | -+ | |||
| 1067 | +2x |
- #' @export+ (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75, |
||
| 289 | -+ | |||
| 1068 | +2x |
- h_simple_term_labels <- function(terms,+ "native" |
||
| 290 | +1069 |
- table) {
+ ), |
||
| 291 | -45x | +1070 | +2x |
- checkmate::assert_true(is.table(table))+ gp = grid::gpar(fontface = "italic", fontsize = 10) |
| 292 | -45x | +|||
| 1071 | +
- checkmate::assert_multi_class(terms, classes = c("factor", "character"))
+ ) |
|||
| 293 | -45x | +|||
| 1072 | +
- terms <- as.character(terms)+ ) |
|||
| 294 | -45x | +1073 | +2x |
- term_n <- table[terms]+ gb_patient_at_risk <- grid::gList( |
| 295 | -45x | +1074 | +2x |
- paste0(terms, ", n = ", term_n)+ grid::rectGrob( |
| 296 | -+ | |||
| 1075 | +2x |
- }+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
||
| 297 | -+ | |||
| 1076 | +2x |
-
+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
|
||
| 298 | -+ | |||
| 1077 | +2x |
- #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
||
| 299 | +1078 |
- #' of numbers of patients.+ ), |
||
| 300 | -+ | |||
| 1079 | +2x |
- #'+ grid::textGrob( |
||
| 301 | -+ | |||
| 1080 | +2x |
- #' @param terms1 (`character`)\cr terms for first dimension (rows).+ label = annot_tbl$n.risk, |
||
| 302 | -+ | |||
| 1081 | +2x |
- #' @param terms2 (`character`)\cr terms for second dimension (rows).+ x = grid::unit(annot_tbl$time, "native"), |
||
| 303 | -+ | |||
| 1082 | +2x |
- #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the+ y = grid::unit( |
||
| 304 | -+ | |||
| 1083 | +2x |
- #' number of patients. In that case they can only be scalar (strings).+ (max(y_str_unit) - y_str_unit) + .5, |
||
| 305 | -+ | |||
| 1084 | +2x |
- #'+ "line" |
||
| 306 | -+ | |||
| 1085 | +2x |
- #' @return Term labels containing numbers of patients.+ ) # maybe native |
||
| 307 | +1086 |
- #'+ ) |
||
| 308 | +1087 |
- #' @export+ ) |
||
| 309 | +1088 |
- h_interaction_term_labels <- function(terms1,+ |
||
| 310 | -+ | |||
| 1089 | +2x |
- terms2,+ ret <- list( |
||
| 311 | -+ | |||
| 1090 | +2x |
- table,+ at_risk = grid::gList( |
||
| 312 | -+ | |||
| 1091 | +2x |
- any = FALSE) {
+ grid::gTree( |
||
| 313 | -8x | +1092 | +2x |
- checkmate::assert_true(is.table(table))+ vp = vp_table, |
| 314 | -8x | +1093 | +2x |
- checkmate::assert_flag(any)+ children = grid::gList( |
| 315 | -8x | +1094 | +2x |
- checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ grid::gTree( |
| 316 | -8x | +1095 | +2x |
- checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ vp = grid::dataViewport( |
| 317 | -8x | +1096 | +2x |
- terms1 <- as.character(terms1)+ xscale = c(0, xlim) + c(-0.05, 0.05) * xlim, |
| 318 | -8x | +1097 | +2x |
- terms2 <- as.character(terms2)+ yscale = c(0, nlines + 1), |
| 319 | -8x | +1098 | +2x |
- if (any) {
+ extension = c(0.05, 0) |
| 320 | -4x | +|||
| 1099 | +
- checkmate::assert_scalar(terms1)+ ), |
|||
| 321 | -4x | +1100 | +2x |
- checkmate::assert_scalar(terms2)+ children = grid::gList(gb_patient_at_risk) |
| 322 | -4x | +|||
| 1101 | +
- paste0(+ ) |
|||
| 323 | -4x | +|||
| 1102 | +
- terms1, " or ", terms2, ", n = ",+ ) |
|||
| 324 | +1103 |
- # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.+ )+ |
+ ||
| 1104 | ++ |
+ ), |
||
| 325 | -4x | +1105 | +2x |
- sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]+ label = grid::gList( |
| 326 | -+ | |||
| 1106 | +2x |
- )+ grid::gTree( |
||
| 327 | -+ | |||
| 1107 | +2x |
- } else {
+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
||
| 328 | -4x | +1108 | +2x |
- term_n <- table[cbind(terms1, terms2)]+ children = grid::gList( |
| 329 | -4x | +1109 | +2x |
- paste0(terms1, " * ", terms2, ", n = ", term_n)+ grid::gTree( |
| 330 | -+ | |||
| 1110 | +2x |
- }+ vp = grid::dataViewport( |
||
| 331 | -+ | |||
| 1111 | +2x |
- }+ xscale = 0:1, |
||
| 332 | -+ | |||
| 1112 | +2x |
-
+ yscale = c(0, nlines + 1), |
||
| 333 | -+ | |||
| 1113 | +2x |
- #' @describeIn h_logistic_regression Helper function to tabulate the main effect+ extension = c(0.0, 0) |
||
| 334 | +1114 |
- #' results of a (conditional) logistic regression model.+ ), |
||
| 335 | -+ | |||
| 1115 | +2x |
- #'+ children = grid::gList(gb_table_left_annot) |
||
| 336 | +1116 |
- #' @return Tabulated main effect results from a logistic regression model.+ ) |
||
| 337 | +1117 |
- #'+ ) |
||
| 338 | +1118 |
- #' @examples+ ) |
||
| 339 | +1119 |
- #' h_glm_simple_term_extract("AGE", mod1)
+ ) |
||
| 340 | +1120 |
- #' h_glm_simple_term_extract("ARMCD", mod1)
+ ) |
||
| 341 | +1121 |
- #'+ |
||
| 342 | -+ | |||
| 1122 | +2x |
- #' @export+ if (title) {
|
||
| 343 | -+ | |||
| 1123 | +2x |
- h_glm_simple_term_extract <- function(x, fit_glm) {
+ ret[["title"]] <- grid::gList( |
||
| 344 | -73x | +1124 | +2x |
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ grid::gTree( |
| 345 | -73x | +1125 | +2x |
- checkmate::assert_string(x)+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
| 346 | -+ | |||
| 1126 | +2x |
-
+ children = grid::gList( |
||
| 347 | -73x | +1127 | +2x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ grid::gTree( |
| 348 | -73x | +1128 | +2x |
- xs_level <- fit_glm$xlevels+ vp = grid::dataViewport( |
| 349 | -73x | +1129 | +2x |
- xs_coef <- summary(fit_glm)$coefficients+ xscale = 0:1, |
| 350 | -73x | +1130 | +2x |
- stats <- if (inherits(fit_glm, "glm")) {
+ yscale = c(0, 1), |
| 351 | -61x | +1131 | +2x |
- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ extension = c(0, 0) |
| 352 | +1132 |
- } else {
+ ), |
||
| 353 | -12x | +1133 | +2x |
- c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ children = grid::gList(gb_table_title) |
| 354 | +1134 |
- }+ ) |
||
| 355 | +1135 |
- # Make sure x is not an interaction term.+ ) |
||
| 356 | -73x | +|||
| 1136 | +
- checkmate::assert_subset(x, names(xs_class))+ ) |
|||
| 357 | -73x | +|||
| 1137 | +
- x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ ) |
|||
| 358 | -73x | +|||
| 1138 | +
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ } |
|||
| 359 | -73x | +|||
| 1139 | +
- colnames(x_stats) <- names(stats)+ |
|||
| 360 | -73x | +1140 | +2x |
- x_stats$estimate <- as.list(x_stats$estimate)+ ret |
| 361 | -73x | +|||
| 1141 | +
- x_stats$std_error <- as.list(x_stats$std_error)+ } |
|||
| 362 | -73x | +|||
| 1142 | +
- x_stats$pvalue <- as.list(x_stats$pvalue)+ |
|||
| 363 | -73x | +|||
| 1143 | +
- x_stats$df <- as.list(1)+ #' Helper Function: Survival Estimations |
|||
| 364 | -73x | +|||
| 1144 | +
- if (xs_class[x] == "numeric") {
+ #' |
|||
| 365 | -58x | +|||
| 1145 | +
- x_stats$term <- x+ #' @description `r lifecycle::badge("stable")`
|
|||
| 366 | -58x | +|||
| 1146 | +
- x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ #' |
|||
| 367 | -46x | +|||
| 1147 | +
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval. |
|||
| 368 | +1148 |
- } else {
+ #' |
||
| 369 | +1149 |
- # We just fill in here with the `term` itself as we don't have the data available.+ #' @inheritParams h_data_plot |
||
| 370 | -12x | +|||
| 1150 | +
- x+ #' |
|||
| 371 | +1151 |
- }+ #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
||
| 372 | -58x | +|||
| 1152 | +
- x_stats$is_variable_summary <- FALSE+ #' |
|||
| 373 | -58x | +|||
| 1153 | +
- x_stats$is_term_summary <- TRUE+ #' @examples |
|||
| 374 | +1154 |
- } else {
+ #' \donttest{
|
||
| 375 | -15x | +|||
| 1155 | +
- checkmate::assert_class(fit_glm, "glm")+ #' library(dplyr) |
|||
| 376 | +1156 |
- # The reason is that we don't have the original data set in the `clogit` object+ #' library(survival) |
||
| 377 | +1157 |
- # and therefore cannot determine the `x_numbers` here.+ #' |
||
| 378 | -15x | +|||
| 1158 | +
- x_numbers <- table(fit_glm$data[[x]])+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS") |
|||
| 379 | -15x | +|||
| 1159 | +
- x_stats$term <- xs_level[[x]][-1]+ #' fit <- survfit( |
|||
| 380 | -15x | +|||
| 1160 | +
- x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ #' form = Surv(AVAL, 1 - CNSR) ~ ARMCD, |
|||
| 381 | -15x | +|||
| 1161 | +
- x_stats$is_variable_summary <- FALSE+ #' data = adtte |
|||
| 382 | -15x | +|||
| 1162 | +
- x_stats$is_term_summary <- TRUE+ #' ) |
|||
| 383 | -15x | +|||
| 1163 | +
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ #' h_tbl_median_surv(fit_km = fit) |
|||
| 384 | -15x | +|||
| 1164 | +
- x_main <- data.frame(+ #' } |
|||
| 385 | -15x | +|||
| 1165 | +
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ #' |
|||
| 386 | -15x | +|||
| 1166 | +
- term = xs_level[[x]][1],+ #' @export |
|||
| 387 | -15x | +|||
| 1167 | +
- term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ h_tbl_median_surv <- function(fit_km, armval = "All") {
|
|||
| 388 | -15x | +1168 | +3x |
- df = main_effects[x, "Df", drop = TRUE],+ y <- if (is.null(fit_km$strata)) {
|
| 389 | -15x | +|||
| 1169 | +! |
- stringsAsFactors = FALSE+ as.data.frame(t(summary(fit_km)$table), row.names = armval) |
||
| 390 | +1170 |
- )+ } else {
|
||
| 391 | -15x | +1171 | +3x |
- x_main$pvalue <- as.list(x_main$pvalue)+ tbl <- summary(fit_km)$table |
| 392 | -15x | +1172 | +3x |
- x_main$df <- as.list(x_main$df)+ rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
|
| 393 | -15x | +1173 | +3x |
- x_main$estimate <- list(numeric(0))+ rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2] |
| 394 | -15x | +1174 | +3x |
- x_main$std_error <- list(numeric(0))+ as.data.frame(tbl) |
| 395 | -15x | +|||
| 1175 | +
- if (length(xs_level[[x]][-1]) == 1) {
+ } |
|||
| 396 | -6x | +1176 | +3x |
- x_main$pvalue <- list(numeric(0))+ conf.int <- summary(fit_km)$conf.int # nolint |
| 397 | -6x | +1177 | +3x |
- x_main$df <- list(numeric(0))- |
-
| 398 | -- |
- }+ y$records <- round(y$records) |
||
| 399 | -15x | +1178 | +3x |
- x_main$is_variable_summary <- TRUE+ y$median <- signif(y$median, 4) |
| 400 | -15x | +1179 | +3x |
- x_main$is_term_summary <- FALSE+ y$`CI` <- paste0( |
| 401 | -15x | +1180 | +3x |
- x_stats <- rbind(x_main, x_stats)+ "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
|
| 402 | +1181 |
- }+ ) |
||
| 403 | -73x | +1182 | +3x |
- x_stats$variable <- x+ stats::setNames( |
| 404 | -73x | +1183 | +3x |
- x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
+ y[c("records", "median", "CI")],
|
| 405 | -61x | +1184 | +3x |
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ c("N", "Median", f_conf_level(conf.int))
|
| 406 | +1185 |
- } else {
+ ) |
||
| 407 | -12x | +|||
| 1186 | +
- x+ } |
|||
| 408 | +1187 |
- }+ |
||
| 409 | -73x | +|||
| 1188 | +
- x_stats$interaction <- ""+ #' Helper Function: Survival Estimation Grob |
|||
| 410 | -73x | +|||
| 1189 | +
- x_stats$interaction_label <- ""+ #' |
|||
| 411 | -73x | +|||
| 1190 | +
- x_stats$reference <- ""+ #' @description `r lifecycle::badge("stable")`
|
|||
| 412 | -73x | +|||
| 1191 | +
- x_stats$reference_label <- ""+ #' |
|||
| 413 | -73x | +|||
| 1192 | +
- rownames(x_stats) <- NULL+ #' The survival fit is transformed in a grob containing a table with groups in |
|||
| 414 | -73x | +|||
| 1193 | +
- x_stats[c(+ #' rows characterized by N, median and 95% confidence interval. |
|||
| 415 | -73x | +|||
| 1194 | +
- "variable",+ #' |
|||
| 416 | -73x | +|||
| 1195 | +
- "variable_label",+ #' @inheritParams g_km |
|||
| 417 | -73x | +|||
| 1196 | +
- "term",+ #' @inheritParams h_data_plot |
|||
| 418 | -73x | +|||
| 1197 | +
- "term_label",+ #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()]. |
|||
| 419 | -73x | +|||
| 1198 | +
- "interaction",+ #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location. |
|||
| 420 | -73x | +|||
| 1199 | +
- "interaction_label",+ #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location. |
|||
| 421 | -73x | +|||
| 1200 | +
- "reference",+ #' @param width (`unit`)\cr width (as a unit) to use when printing the grob. |
|||
| 422 | -73x | +|||
| 1201 | +
- "reference_label",+ #' |
|||
| 423 | -73x | +|||
| 1202 | +
- "estimate",+ #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
|||
| 424 | -73x | +|||
| 1203 | +
- "std_error",+ #' |
|||
| 425 | -73x | +|||
| 1204 | +
- "df",+ #' @examples |
|||
| 426 | -73x | +|||
| 1205 | +
- "pvalue",+ #' \donttest{
|
|||
| 427 | -73x | +|||
| 1206 | +
- "is_variable_summary",+ #' library(dplyr) |
|||
| 428 | -73x | +|||
| 1207 | +
- "is_term_summary"+ #' library(survival) |
|||
| 429 | +1208 |
- )]+ #' library(grid) |
||
| 430 | +1209 |
- }+ #' |
||
| 431 | +1210 |
-
+ #' grid::grid.newpage() |
||
| 432 | +1211 |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction term+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
||
| 433 | +1212 |
- #' results of a logistic regression model.+ #' tern_ex_adtte %>% |
||
| 434 | +1213 |
- #'+ #' filter(PARAMCD == "OS") %>% |
||
| 435 | +1214 |
- #' @return Tabulated interaction term results from a logistic regression model.+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 436 | +1215 |
- #'+ #' h_grob_median_surv() %>% |
||
| 437 | +1216 |
- #' @examples+ #' grid::grid.draw() |
||
| 438 | +1217 |
- #' h_glm_interaction_extract("ARMCD:AGE", mod2)
+ #' } |
||
| 439 | +1218 |
#' |
||
| 440 | +1219 |
#' @export |
||
| 441 | +1220 |
- h_glm_interaction_extract <- function(x, fit_glm) {
- |
- ||
| 442 | -6x | -
- vars <- h_get_interaction_vars(fit_glm)- |
- ||
| 443 | -6x | -
- xs_class <- attr(fit_glm$terms, "dataClasses")+ h_grob_median_surv <- function(fit_km, |
||
| 444 | +1221 | - - | -||
| 445 | -6x | -
- checkmate::assert_string(x)+ armval = "All", |
||
| 446 | +1222 |
-
+ x = 0.9, |
||
| 447 | +1223 |
- # Only take two-way interaction- |
- ||
| 448 | -6x | -
- checkmate::assert_vector(vars, len = 2)+ y = 0.9, |
||
| 449 | +1224 |
-
+ width = grid::unit(0.3, "npc"), |
||
| 450 | +1225 |
- # Only consider simple case: first variable in interaction is arm, a categorical variable+ ttheme = gridExtra::ttheme_default()) {
|
||
| 451 | -6x | +1226 | +2x |
- checkmate::assert_disjunct(xs_class[vars[1]], "numeric")+ data <- h_tbl_median_surv(fit_km, armval = armval) |
| 452 | +1227 | |||
| 453 | -6x | -
- xs_level <- fit_glm$xlevels- |
- ||
| 454 | -6x | -
- xs_coef <- summary(fit_glm)$coefficients- |
- ||
| 455 | -6x | -
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")- |
- ||
| 456 | -6x | +1228 | +2x |
- stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in") |
| 457 | -6x | +1229 | +2x |
- v1_comp <- xs_level[[vars[1]]][-1]+ height <- width * (nrow(data) + 1) / 12 |
| 458 | -6x | +|||
| 1230 | +
- if (xs_class[vars[2]] == "numeric") {
+
|
|||
| 459 | -3x | +1231 | +2x |
- x_stats <- as.data.frame(+ w <- paste(" ", c(
|
| 460 | -3x | +1232 | +2x |
- xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],+ rownames(data)[which.max(nchar(rownames(data)))], |
| 461 | -3x | +1233 | +2x |
- stringsAsFactors = FALSE+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
| 462 | +1234 |
- )- |
- ||
| 463 | -3x | -
- colnames(x_stats) <- names(stats)+ )) |
||
| 464 | -3x | +1235 | +2x |
- x_stats$term <- v1_comp+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
| 465 | -3x | +|||
| 1236 | +
- x_numbers <- table(fit_glm$data[[vars[1]]])+ |
|||
| 466 | -3x | +1237 | +2x |
- x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)+ w_txt <- sapply(1:64, function(x) {
|
| 467 | -3x | +1238 | +128x |
- v1_ref <- xs_level[[vars[1]]][1]+ graphics::par(ps = x) |
| 468 | -3x | +1239 | +128x |
- term_main <- v1_ref+ graphics::strwidth(w[4], units = "in") |
| 469 | -3x | +|||
| 1240 | +
- ref_label <- h_simple_term_labels(v1_ref, x_numbers)+ }) |
|||
| 470 | -3x | +1241 | +2x |
- } else if (xs_class[vars[2]] != "numeric") {
+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
| 471 | -3x | +|||
| 1242 | +
- v2_comp <- xs_level[[vars[2]]][-1]+ |
|||
| 472 | -3x | +1243 | +2x |
- v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ h_txt <- sapply(1:64, function(x) {
|
| 473 | -3x | +1244 | +128x |
- x_sel <- paste(+ graphics::par(ps = x) |
| 474 | -3x | +1245 | +128x |
- paste0(vars[1], v1_v2_grid$v1),+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
| 475 | -3x | +|||
| 1246 | +
- paste0(vars[2], v1_v2_grid$v2),+ }) |
|||
| 476 | -3x | +1247 | +2x |
- sep = ":"+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
| 477 | +1248 |
- )+ |
||
| 478 | -3x | +1249 | +2x |
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ if (ttheme$core$fg_params$fontsize == 12) {
|
| 479 | -3x | +1250 | +2x |
- colnames(x_stats) <- names(stats)+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 480 | -3x | +1251 | +2x |
- x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2)+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 481 | -3x | +1252 | +2x |
- x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]])+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 482 | -3x | +|||
| 1253 | +
- x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers)+ } |
|||
| 483 | -3x | +|||
| 1254 | +
- v1_ref <- xs_level[[vars[1]]][1]+ |
|||
| 484 | -3x | +1255 | +2x |
- v2_ref <- xs_level[[vars[2]]][1]+ gt <- gridExtra::tableGrob( |
| 485 | -3x | +1256 | +2x |
- term_main <- paste(vars[1], vars[2], sep = " * ")+ d = data, |
| 486 | -3x | +1257 | +2x |
- ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)+ theme = ttheme |
| 487 | +1258 |
- }- |
- ||
| 488 | -6x | -
- x_stats$df <- as.list(1)+ ) |
||
| 489 | -6x | +1259 | +2x |
- x_stats$pvalue <- as.list(x_stats$pvalue)+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
| 490 | -6x | +1260 | +2x |
- x_stats$is_variable_summary <- FALSE+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
| 491 | -6x | +|||
| 1261 | +
- x_stats$is_term_summary <- TRUE+ |
|||
| 492 | -6x | +1262 | +2x |
- x_main <- data.frame(+ vp <- grid::viewport( |
| 493 | -6x | +1263 | +2x |
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
| 494 | -6x | +1264 | +2x |
- term = term_main,+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
| 495 | -6x | +1265 | +2x |
- term_label = paste("Reference", ref_label),
+ height = height, |
| 496 | -6x | +1266 | +2x |
- df = main_effects[x, "Df", drop = TRUE],+ width = width, |
| 497 | -6x | +1267 | +2x |
- stringsAsFactors = FALSE+ just = c("right", "top")
|
| 498 | +1268 |
) |
||
| 499 | -6x | -
- x_main$pvalue <- as.list(x_main$pvalue)- |
- ||
| 500 | -6x | +|||
| 1269 | +
- x_main$df <- as.list(x_main$df)+ |
|||
| 501 | -6x | +1270 | +2x |
- x_main$estimate <- list(numeric(0))+ grid::gList( |
| 502 | -6x | +1271 | +2x |
- x_main$std_error <- list(numeric(0))+ grid::gTree( |
| 503 | -6x | +1272 | +2x |
- x_main$is_variable_summary <- TRUE+ vp = vp, |
| 504 | -6x | +1273 | +2x |
- x_main$is_term_summary <- FALSE+ children = grid::gList(gt) |
| 505 | +1274 | - - | -||
| 506 | -6x | -
- x_stats <- rbind(x_main, x_stats)- |
- ||
| 507 | -6x | -
- x_stats$variable <- x- |
- ||
| 508 | -6x | -
- x_stats$variable_label <- paste(- |
- ||
| 509 | -6x | -
- "Interaction of",+ ) |
||
| 510 | -6x | +|||
| 1275 | +
- formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE),+ ) |
|||
| 511 | +1276 |
- "*",+ } |
||
| 512 | -6x | +|||
| 1277 | +
- formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE)+ |
|||
| 513 | +1278 |
- )+ #' Helper: Grid Object with y-axis Annotation |
||
| 514 | -6x | +|||
| 1279 | +
- x_stats$interaction <- ""+ #' |
|||
| 515 | -6x | +|||
| 1280 | +
- x_stats$interaction_label <- ""+ #' @description `r lifecycle::badge("stable")`
|
|||
| 516 | -6x | +|||
| 1281 | +
- x_stats$reference <- ""+ #' |
|||
| 517 | -6x | +|||
| 1282 | +
- x_stats$reference_label <- ""+ #' Build the y-axis annotation from a decomposed `ggplot`. |
|||
| 518 | -6x | +|||
| 1283 | +
- rownames(x_stats) <- NULL+ #' |
|||
| 519 | -6x | +|||
| 1284 | +
- x_stats[c(+ #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`. |
|||
| 520 | -6x | +|||
| 1285 | +
- "variable",+ #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`. |
|||
| 521 | -6x | +|||
| 1286 | +
- "variable_label",+ #' |
|||
| 522 | -6x | +|||
| 1287 | +
- "term",+ #' @return a `gTree` object containing the y-axis annotation from a `ggplot`. |
|||
| 523 | -6x | +|||
| 1288 | +
- "term_label",+ #' |
|||
| 524 | -6x | +|||
| 1289 | +
- "interaction",+ #' @examples |
|||
| 525 | -6x | +|||
| 1290 | +
- "interaction_label",+ #' \donttest{
|
|||
| 526 | -6x | +|||
| 1291 | +
- "reference",+ #' library(dplyr) |
|||
| 527 | -6x | +|||
| 1292 | +
- "reference_label",+ #' library(survival) |
|||
| 528 | -6x | +|||
| 1293 | +
- "estimate",+ #' library(grid) |
|||
| 529 | -6x | +|||
| 1294 | +
- "std_error",+ #' |
|||
| 530 | -6x | +|||
| 1295 | +
- "df",+ #' fit_km <- tern_ex_adtte %>% |
|||
| 531 | -6x | +|||
| 1296 | +
- "pvalue",+ #' filter(PARAMCD == "OS") %>% |
|||
| 532 | -6x | +|||
| 1297 | +
- "is_variable_summary",+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 533 | -6x | +|||
| 1298 | +
- "is_term_summary"+ #' data_plot <- h_data_plot(fit_km = fit_km) |
|||
| 534 | +1299 |
- )]+ #' xticks <- h_xticks(data = data_plot) |
||
| 535 | +1300 |
- }+ #' gg <- h_ggkm( |
||
| 536 | +1301 |
-
+ #' data = data_plot, |
||
| 537 | +1302 |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction+ #' censor_show = TRUE, |
||
| 538 | +1303 |
- #' results of a logistic regression model. This basically is a wrapper for+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 539 | +1304 |
- #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results+ #' title = "title", footnotes = "footnotes", yval = "Survival" |
||
| 540 | +1305 |
- #' in the right data frame format.+ #' ) |
||
| 541 | +1306 |
#' |
||
| 542 | +1307 |
- #' @return A `data.frame` of tabulated interaction term results from a logistic regression model.+ #' g_el <- h_decompose_gg(gg) |
||
| 543 | +1308 |
#' |
||
| 544 | +1309 |
- #' @examples+ #' grid::grid.newpage() |
||
| 545 | +1310 |
- #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
+ #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20)) |
||
| 546 | +1311 |
- #'+ #' pushViewport(pvp) |
||
| 547 | +1312 |
- #' @export+ #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)) |
||
| 548 | +1313 |
- h_glm_inter_term_extract <- function(odds_ratio_var,+ #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA)) |
||
| 549 | +1314 |
- interaction_var,+ #' } |
||
| 550 | +1315 |
- fit_glm,+ #' |
||
| 551 | +1316 |
- ...) {
+ #' @export |
||
| 552 | +1317 |
- # First obtain the main effects.+ h_grob_y_annot <- function(ylab, yaxis) {
|
||
| 553 | -11x | +1318 | +2x |
- main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm)+ grid::gList( |
| 554 | -11x | +1319 | +2x |
- main_stats$is_reference_summary <- FALSE+ grid::gTree( |
| 555 | -11x | +1320 | +2x |
- main_stats$odds_ratio <- NA+ vp = grid::viewport( |
| 556 | -11x | +1321 | +2x |
- main_stats$lcl <- NA+ width = grid::convertX(yaxis$width + ylab$width, "pt"), |
| 557 | -11x | +1322 | +2x |
- main_stats$ucl <- NA+ x = grid::unit(1, "npc"), |
| 558 | -+ | |||
| 1323 | +2x |
-
+ just = "right" |
||
| 559 | +1324 |
- # Then we get the odds ratio estimates and put into df form.- |
- ||
| 560 | -11x | -
- or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...)+ ), |
||
| 561 | -11x | +1325 | +2x |
- is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric"+ children = grid::gList(cbind(ylab, yaxis)) |
| 562 | +1326 |
-
+ ) |
||
| 563 | -11x | +|||
| 1327 | +
- if (is_num_or_var) {
+ ) |
|||
| 564 | +1328 |
- # Numeric OR variable case.+ } |
||
| 565 | -3x | +|||
| 1329 | +
- references <- names(or_numbers)+ |
|||
| 566 | -3x | +|||
| 1330 | +
- n_ref <- length(references)+ #' Helper Function: Pairwise `CoxPH` table |
|||
| 567 | +1331 |
-
+ #' |
||
| 568 | -3x | +|||
| 1332 | +
- extract_from_list <- function(l, name, pos = 1) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 569 | -9x | +|||
| 1333 | +
- unname(unlist(+ #' |
|||
| 570 | -9x | +|||
| 1334 | +
- lapply(or_numbers, function(x) {
+ #' Create a `data.frame` of pairwise stratified or unstratified `CoxPH` analysis results. |
|||
| 571 | -27x | +|||
| 1335 | +
- x[[name]][pos]+ #' |
|||
| 572 | +1336 |
- })+ #' @inheritParams g_km |
||
| 573 | +1337 |
- ))+ #' |
||
| 574 | +1338 |
- }+ #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
||
| 575 | -3x | +|||
| 1339 | +
- or_stats <- data.frame(+ #' and `p-value (log-rank)`. |
|||
| 576 | -3x | +|||
| 1340 | +
- variable = odds_ratio_var,+ #' |
|||
| 577 | -3x | +|||
| 1341 | +
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ #' @examples |
|||
| 578 | -3x | +|||
| 1342 | +
- term = odds_ratio_var,+ #' \donttest{
|
|||
| 579 | -3x | +|||
| 1343 | +
- term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ #' library(dplyr) |
|||
| 580 | -3x | +|||
| 1344 | +
- interaction = interaction_var,+ #' |
|||
| 581 | -3x | +|||
| 1345 | +
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ #' adtte <- tern_ex_adtte %>% |
|||
| 582 | -3x | +|||
| 1346 | +
- reference = references,+ #' filter(PARAMCD == "OS") %>% |
|||
| 583 | -3x | +|||
| 1347 | +
- reference_label = references,+ #' mutate(is_event = CNSR == 0) |
|||
| 584 | -3x | +|||
| 1348 | +
- estimate = NA,+ #' |
|||
| 585 | -3x | +|||
| 1349 | +
- std_error = NA,+ #' h_tbl_coxph_pairwise( |
|||
| 586 | -3x | +|||
| 1350 | +
- odds_ratio = extract_from_list(or_numbers, "or"),+ #' df = adtte, |
|||
| 587 | -3x | +|||
| 1351 | +
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"), |
|||
| 588 | -3x | +|||
| 1352 | +
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ #' control_coxph_pw = control_coxph(conf_level = 0.9) |
|||
| 589 | -3x | +|||
| 1353 | +
- df = NA,+ #' ) |
|||
| 590 | -3x | +|||
| 1354 | +
- pvalue = NA,+ #' } |
|||
| 591 | -3x | +|||
| 1355 | +
- is_variable_summary = FALSE,+ #' |
|||
| 592 | -3x | +|||
| 1356 | +
- is_term_summary = FALSE,+ #' @export |
|||
| 593 | -3x | +|||
| 1357 | +
- is_reference_summary = TRUE+ h_tbl_coxph_pairwise <- function(df, |
|||
| 594 | +1358 |
- )+ variables, |
||
| 595 | +1359 |
- } else {
+ ref_group_coxph = NULL, |
||
| 596 | +1360 |
- # Categorical OR variable case.+ control_coxph_pw = control_coxph(), |
||
| 597 | -8x | +|||
| 1361 | +
- references <- names(or_numbers[[1]])+ annot_coxph_ref_lbls = FALSE) {
|
|||
| 598 | -8x | +1362 | +3x |
- n_ref <- length(references)+ if ("strat" %in% names(variables)) {
|
| 599 | -+ | |||
| 1363 | +! |
-
+ warning( |
||
| 600 | -8x | +|||
| 1364 | +! |
- extract_from_list <- function(l, name, pos = 1) {
+ "Warning: the `strat` element name of the `variables` list argument to `h_tbl_coxph_pairwise() ", |
||
| 601 | -24x | +|||
| 1365 | +! |
- unname(unlist(+ "was deprecated in tern 0.9.3.\n ", |
||
| 602 | -24x | +|||
| 1366 | +! |
- lapply(or_numbers, function(x) {
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 603 | -42x | +|||
| 1367 | +
- lapply(x, function(y) y[[name]][pos])+ ) |
|||
| 604 | -+ | |||
| 1368 | +! |
- })+ variables[["strata"]] <- variables[["strat"]] |
||
| 605 | +1369 |
- ))+ } |
||
| 606 | +1370 |
- }+ |
||
| 607 | -8x | +1371 | +3x |
- or_stats <- data.frame(+ assert_df_with_variables(df, variables) |
| 608 | -8x | +1372 | +3x |
- variable = odds_ratio_var,+ checkmate::assert_choice(ref_group_coxph, levels(df[[variables$arm]]), null.ok = TRUE) |
| 609 | -8x | +1373 | +3x |
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ checkmate::assert_flag(annot_coxph_ref_lbls) |
| 610 | -8x | +|||
| 1374 | +
- term = rep(names(or_numbers), each = n_ref),+ |
|||
| 611 | -8x | +1375 | +3x |
- term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])),+ arm <- variables$arm |
| 612 | -8x | +1376 | +3x |
- interaction = interaction_var,+ df[[arm]] <- factor(df[[arm]]) |
| 613 | -8x | +|||
| 1377 | +
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ |
|||
| 614 | -8x | +1378 | +3x |
- reference = unlist(lapply(or_numbers, names)),+ ref_group <- if (!is.null(ref_group_coxph)) ref_group_coxph else levels(df[[variables$arm]])[1] |
| 615 | -8x | +1379 | +3x |
- reference_label = unlist(lapply(or_numbers, names)),+ comp_group <- setdiff(levels(df[[arm]]), ref_group) |
| 616 | -8x | +|||
| 1380 | +
- estimate = NA,+ |
|||
| 617 | -8x | +1381 | +3x |
- std_error = NA,+ results <- Map(function(comp) {
|
| 618 | -8x | +1382 | +6x |
- odds_ratio = extract_from_list(or_numbers, "or"),+ res <- s_coxph_pairwise( |
| 619 | -8x | +1383 | +6x |
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ df = df[df[[arm]] == comp, , drop = FALSE], |
| 620 | -8x | +1384 | +6x |
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ .ref_group = df[df[[arm]] == ref_group, , drop = FALSE], |
| 621 | -8x | +1385 | +6x |
- df = NA,+ .in_ref_col = FALSE, |
| 622 | -8x | +1386 | +6x |
- pvalue = NA,+ .var = variables$tte, |
| 623 | -8x | +1387 | +6x |
- is_variable_summary = FALSE,+ is_event = variables$is_event, |
| 624 | -8x | +1388 | +6x |
- is_term_summary = FALSE,+ strata = variables$strata, |
| 625 | -8x | +1389 | +6x |
- is_reference_summary = TRUE+ control = control_coxph_pw |
| 626 | +1390 |
) |
||
| 627 | -+ | |||
| 1391 | +6x |
- }+ res_df <- data.frame( |
||
| 628 | -+ | |||
| 1392 | +6x |
-
+ hr = format(round(res$hr, 2), nsmall = 2), |
||
| 629 | -11x | +1393 | +6x |
- df <- rbind(+ hr_ci = paste0( |
| 630 | -11x | +1394 | +6x |
- main_stats[, names(or_stats)],+ "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
|
| 631 | -11x | +1395 | +6x |
- or_stats+ format(round(res$hr_ci[2], 2), nsmall = 2), ")" |
| 632 | +1396 |
- )+ ), |
||
| 633 | -11x | +1397 | +6x |
- df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ]+ pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),+ |
+
| 1398 | +6x | +
+ stringsAsFactors = FALSE |
||
| 634 | +1399 |
- }+ )+ |
+ ||
| 1400 | +6x | +
+ colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
+ |
+ ||
| 1401 | +6x | +
+ row.names(res_df) <- comp+ |
+ ||
| 1402 | +6x | +
+ res_df+ |
+ ||
| 1403 | +3x | +
+ }, comp_group)+ |
+ ||
| 1404 | +! | +
+ if (annot_coxph_ref_lbls) names(results) <- paste(comp_group, "vs.", ref_group) |
||
| 635 | +1405 | |||
| 636 | -+ | |||
| 1406 | +3x |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ do.call(rbind, results) |
||
| 637 | +1407 |
- #' odds ratios and confidence intervals of simple terms.+ } |
||
| 638 | +1408 |
- #'+ |
||
| 639 | +1409 |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ #' Helper Function: `CoxPH` Grob |
||
| 640 | +1410 |
#' |
||
| 641 | +1411 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 642 | +1412 |
- #' h_logistic_simple_terms("AGE", mod1)
+ #' |
||
| 643 | +1413 |
- #'+ #' Grob of `rtable` output from [h_tbl_coxph_pairwise()] |
||
| 644 | +1414 |
- #' @export+ #' |
||
| 645 | +1415 |
- h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
+ #' @inheritParams h_grob_median_surv |
||
| 646 | -52x | +|||
| 1416 | +
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ #' @param ... arguments will be passed to [h_tbl_coxph_pairwise()]. |
|||
| 647 | -52x | +|||
| 1417 | +
- if (inherits(fit_glm, "glm")) {
+ #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location. |
|||
| 648 | -41x | +|||
| 1418 | +
- checkmate::assert_set_equal(fit_glm$family$family, "binomial")+ #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location. |
|||
| 649 | +1419 |
- }+ #' @param width (`unit`)\cr width (as a unit) to use when printing the grob. |
||
| 650 | -52x | +|||
| 1420 | +
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ #' |
|||
| 651 | -52x | +|||
| 1421 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
|||
| 652 | -52x | +|||
| 1422 | +
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ #' and `p-value (log-rank)`. |
|||
| 653 | -52x | +|||
| 1423 | +
- checkmate::assert_subset(x, terms_name)+ #' |
|||
| 654 | -52x | +|||
| 1424 | +
- if (length(interaction) != 0) {
+ #' @examples |
|||
| 655 | +1425 |
- # Make sure any item in x is not part of interaction term+ #' \donttest{
|
||
| 656 | -1x | +|||
| 1426 | +
- checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":")))+ #' library(dplyr) |
|||
| 657 | +1427 |
- }+ #' library(survival) |
||
| 658 | -52x | +|||
| 1428 | +
- x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm)+ #' library(grid) |
|||
| 659 | -52x | +|||
| 1429 | +
- x_stats <- do.call(rbind, x_stats)+ #' |
|||
| 660 | -52x | +|||
| 1430 | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ #' grid::grid.newpage() |
|||
| 661 | -52x | +|||
| 1431 | +
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
|||
| 662 | -52x | +|||
| 1432 | +
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ #' data <- tern_ex_adtte %>% |
|||
| 663 | -52x | +|||
| 1433 | +
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ #' filter(PARAMCD == "OS") %>% |
|||
| 664 | -52x | +|||
| 1434 | +
- x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl)+ #' mutate(is_event = CNSR == 0) |
|||
| 665 | -52x | +|||
| 1435 | +
- x_stats+ #' tbl_grob <- h_grob_coxph( |
|||
| 666 | +1436 |
- }+ #' df = data, |
||
| 667 | +1437 |
-
+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"), |
||
| 668 | +1438 |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5 |
||
| 669 | +1439 |
- #' odds ratios and confidence intervals of interaction terms.+ #' ) |
||
| 670 | +1440 |
- #'+ #' grid::grid.draw(tbl_grob) |
||
| 671 | +1441 |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ #' } |
||
| 672 | +1442 |
#' |
||
| 673 | +1443 |
- #' @examples+ #' @export |
||
| 674 | +1444 |
- #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
+ h_grob_coxph <- function(..., |
||
| 675 | +1445 |
- #'+ x = 0, |
||
| 676 | +1446 |
- #' @export+ y = 0, |
||
| 677 | +1447 |
- h_logistic_inter_terms <- function(x,+ width = grid::unit(0.4, "npc"), |
||
| 678 | +1448 |
- fit_glm,+ ttheme = gridExtra::ttheme_default( |
||
| 679 | +1449 |
- conf_level = 0.95,+ padding = grid::unit(c(1, .5), "lines"), |
||
| 680 | +1450 |
- at = NULL) {
+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
|
||
| 681 | +1451 |
- # Find out the interaction variables and interaction term.+ )) {
|
||
| 682 | -4x | +1452 | +2x |
- inter_vars <- h_get_interaction_vars(fit_glm)+ data <- h_tbl_coxph_pairwise(...)+ |
+
| 1453 | ++ | + | ||
| 683 | -4x | +1454 | +2x |
- checkmate::assert_vector(inter_vars, len = 2)+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in") |
| 684 | -+ | |||
| 1455 | +2x |
-
+ height <- width * (nrow(data) + 1) / 12 |
||
| 685 | +1456 | |||
| 686 | -4x | +1457 | +2x |
- inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))+ w <- paste(" ", c(
|
| 687 | -4x | +1458 | +2x |
- inter_term <- x[inter_term_index]+ rownames(data)[which.max(nchar(rownames(data)))], |
| 688 | -+ | |||
| 1459 | +2x |
-
+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
||
| 689 | +1460 |
- # For the non-interaction vars we need the standard stuff.+ )) |
||
| 690 | -4x | +1461 | +2x |
- normal_terms <- setdiff(x, union(inter_vars, inter_term))+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
| 691 | +1462 | |||
| 692 | -4x | +1463 | +2x |
- x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm)+ w_txt <- sapply(1:64, function(x) {
|
| 693 | -4x | +1464 | +128x |
- x_stats <- do.call(rbind, x_stats)+ graphics::par(ps = x) |
| 694 | -4x | +1465 | +128x |
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ graphics::strwidth(w[4], units = "in") |
| 695 | -4x | +|||
| 1466 | +
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ }) |
|||
| 696 | -4x | +1467 | +2x |
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
| 697 | -4x | +|||
| 1468 | +
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ |
|||
| 698 | -4x | +1469 | +2x |
- normal_stats <- x_stats+ h_txt <- sapply(1:64, function(x) {
|
| 699 | -4x | +1470 | +128x |
- normal_stats$is_reference_summary <- FALSE+ graphics::par(ps = x) |
| 700 | -+ | |||
| 1471 | +128x |
-
+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
||
| 701 | +1472 |
- # Now the interaction term itself.+ }) |
||
| 702 | -4x | +1473 | +2x |
- inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm)+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
| 703 | -4x | +|||
| 1474 | +
- inter_term_stats$odds_ratio <- NA+ |
|||
| 704 | -4x | +1475 | +2x |
- inter_term_stats$lcl <- NA+ if (ttheme$core$fg_params$fontsize == 12) {
|
| 705 | -4x | +1476 | +2x |
- inter_term_stats$ucl <- NA+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 706 | -4x | -
- inter_term_stats$is_reference_summary <- FALSE- |
- ||
| 707 | -+ | 1477 | +2x |
-
+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 708 | -4x | +1478 | +2x |
- is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric"+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 709 | +1479 |
-
+ } |
||
| 710 | +1480 |
- # Interaction stuff.+ |
||
| 711 | -4x | +1481 | +2x |
- inter_stats_one <- h_glm_inter_term_extract(+ tryCatch( |
| 712 | -4x | +1482 | +2x |
- inter_vars[1],+ expr = {
|
| 713 | -4x | +1483 | +2x |
- inter_vars[2],+ gt <- gridExtra::tableGrob( |
| 714 | -4x | +1484 | +2x |
- fit_glm,+ d = data, |
| 715 | -4x | +1485 | +2x |
- conf_level = conf_level,+ theme = ttheme |
| 716 | -4x | -
- at = `if`(is_intervar1_numeric, NULL, at)- |
- ||
| 717 | -+ | 1486 | +2x |
- )+ ) # ERROR 'data' must be of a vector type, was 'NULL' |
| 718 | -4x | +1487 | +2x |
- inter_stats_two <- h_glm_inter_term_extract(+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
| 719 | -4x | +1488 | +2x |
- inter_vars[2],+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
| 720 | -4x | +1489 | +2x |
- inter_vars[1],+ vp <- grid::viewport( |
| 721 | -4x | +1490 | +2x |
- fit_glm,+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
| 722 | -4x | +1491 | +2x |
- conf_level = conf_level,+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
| 723 | -4x | +1492 | +2x |
- at = `if`(is_intervar1_numeric, at, NULL)+ height = height, |
| 724 | -+ | |||
| 1493 | +2x |
- )+ width = width, |
||
| 725 | -+ | |||
| 1494 | +2x |
-
+ just = c("left", "bottom")
|
||
| 726 | +1495 |
- # Now just combine everything in one data frame.+ ) |
||
| 727 | -4x | +1496 | +2x |
- col_names <- c(+ grid::gList( |
| 728 | -4x | -
- "variable",- |
- ||
| 729 | -4x | -
- "variable_label",- |
- ||
| 730 | -4x | +1497 | +2x |
- "term",+ grid::gTree( |
| 731 | -4x | +1498 | +2x |
- "term_label",+ vp = vp, |
| 732 | -4x | +1499 | +2x |
- "interaction",+ children = grid::gList(gt) |
| 733 | -4x | +|||
| 1500 | +
- "interaction_label",+ ) |
|||
| 734 | -4x | +|||
| 1501 | +
- "reference",+ ) |
|||
| 735 | -4x | +|||
| 1502 | +
- "reference_label",+ }, |
|||
| 736 | -4x | +1503 | +2x |
- "estimate",+ error = function(w) {
|
| 737 | -4x | +|||
| 1504 | +! |
- "std_error",+ message(paste( |
||
| 738 | -4x | +|||
| 1505 | +! |
- "df",+ "Warning: Cox table will not be displayed as there is", |
||
| 739 | -4x | +|||
| 1506 | +! |
- "pvalue",+ "not any level to be compared in the arm variable." |
||
| 740 | -4x | +|||
| 1507 | +
- "odds_ratio",+ )) |
|||
| 741 | -4x | +|||
| 1508 | +! |
- "lcl",+ return( |
||
| 742 | -4x | +|||
| 1509 | +! |
- "ucl",+ grid::gList( |
||
| 743 | -4x | +|||
| 1510 | +! |
- "is_variable_summary",+ grid::gTree( |
||
| 744 | -4x | +|||
| 1511 | +! |
- "is_term_summary",+ vp = NULL, |
||
| 745 | -4x | +|||
| 1512 | +! |
- "is_reference_summary"+ children = NULL |
||
| 746 | +1513 |
- )- |
- ||
| 747 | -4x | -
- df <- rbind(- |
- ||
| 748 | -4x | -
- inter_stats_one[, col_names],- |
- ||
| 749 | -4x | -
- inter_stats_two[, col_names],- |
- ||
| 750 | -4x | -
- inter_term_stats[, col_names]+ ) |
||
| 751 | +1514 |
- )- |
- ||
| 752 | -4x | -
- if (length(normal_terms) > 0) {
- |
- ||
| 753 | -4x | -
- df <- rbind(- |
- ||
| 754 | -4x | -
- normal_stats[, col_names],- |
- ||
| 755 | -4x | -
- df+ ) |
||
| 756 | +1515 |
- )+ ) |
||
| 757 | +1516 |
- }- |
- ||
| 758 | -4x | -
- df$ci <- combine_vectors(df$lcl, df$ucl)+ } |
||
| 759 | -4x | +|||
| 1517 | +
- df+ ) |
|||
| 760 | +1518 |
}@@ -45379,14 +44891,14 @@ tern coverage - 90.46% |
| 1 |
- #' Cox Proportional Hazards Regression+ #' Helper Functions for Multivariate Logistic Regression |
|||
| 5 |
- #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis.+ #' Helper functions used in calculations for logistic regression. |
|||
| 8 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_coxreg")`
+ #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
|||
| 9 |
- #' to see available statistics for this function.+ #' 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 |
- #' @details Cox models are the most commonly used methods to estimate the magnitude of+ #' @param x (`string` or `character`)\cr a variable or interaction term in `fit_glm` (depending on the |
|||
| 12 |
- #' the effect in survival analysis. It assumes proportional hazards: the ratio+ #' helper function). |
|||
| 13 |
- #' of the hazards between groups (e.g., two arms) is constant over time.+ #' |
|||
| 14 |
- #' This ratio is referred to as the "hazard ratio" (HR) and is one of the+ #' @examples |
|||
| 15 |
- #' most commonly reported metrics to describe the effect size in survival+ #' library(dplyr) |
|||
| 16 |
- #' analysis (NEST Team, 2020).+ #' library(broom) |
|||
| 18 |
- #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant+ #' adrs_f <- tern_ex_adrs %>% |
|||
| 19 |
- #' helper functions, and [tidy_coxreg] for custom tidy methods.+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 20 |
- #'+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
|||
| 21 |
- #' @examples+ #' mutate( |
|||
| 22 |
- #' library(survival)+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
|||
| 23 |
- #'+ #' RACE = factor(RACE), |
|||
| 24 |
- #' # Testing dataset [survival::bladder].+ #' SEX = factor(SEX) |
|||
| 25 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' ) |
|||
| 26 |
- #' dta_bladder <- with(+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
|||
| 27 |
- #' data = bladder[bladder$enum < 5, ],+ #' mod1 <- fit_logistic( |
|||
| 28 |
- #' tibble::tibble(+ #' data = adrs_f, |
|||
| 29 |
- #' TIME = stop,+ #' variables = list( |
|||
| 30 |
- #' STATUS = event,+ #' response = "Response", |
|||
| 31 |
- #' ARM = as.factor(rx),+ #' arm = "ARMCD", |
|||
| 32 |
- #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
+ #' covariates = c("AGE", "RACE")
|
|||
| 33 |
- #' COVAR2 = factor(+ #' ) |
|||
| 34 |
- #' sample(as.factor(enum)),+ #' ) |
|||
| 35 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ #' mod2 <- fit_logistic( |
|||
| 36 |
- #' ) %>% formatters::with_label("Sex (F/M)")
+ #' data = adrs_f, |
|||
| 37 |
- #' )+ #' variables = list( |
|||
| 38 |
- #' )+ #' response = "Response", |
|||
| 39 |
- #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' arm = "ARMCD", |
|||
| 40 |
- #' dta_bladder$STUDYID <- factor("X")
+ #' covariates = c("AGE", "RACE"),
|
|||
| 41 |
- #'+ #' interaction = "AGE" |
|||
| 42 |
- #' u1_variables <- list(+ #' ) |
|||
| 43 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' ) |
|||
| 44 |
- #' )+ #' |
|||
| 45 |
- #'+ #' @name h_logistic_regression |
|||
| 46 |
- #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ NULL |
|||
| 47 |
- #'+ |
|||
| 48 |
- #' m1_variables <- list(+ #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted |
|||
| 49 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' model assuming only one interaction term. |
|||
| 50 |
- #' )+ #' |
|||
| 51 |
- #'+ #' @return Vector of names of interaction variables. |
|||
| 52 |
- #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ #' |
|||
| 53 |
- #'+ #' @export |
|||
| 54 |
- #' @name cox_regression+ h_get_interaction_vars <- function(fit_glm) {
|
|||
| 55 | -+ | 27x |
- #' @order 1+ checkmate::assert_class(fit_glm, "glm") |
|
| 56 | -+ | 27x |
- NULL+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
|
| 57 | -+ | 27x |
-
+ terms_order <- attr(stats::terms(fit_glm), "order") |
|
| 58 | -+ | 27x |
- #' @describeIn cox_regression Statistics function that transforms results tabulated+ interaction_term <- terms_name[terms_order == 2] |
|
| 59 | -+ | 27x |
- #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list.+ checkmate::assert_string(interaction_term) |
|
| 60 | -+ | 27x |
- #'+ strsplit(interaction_term, split = ":")[[1]] |
|
| 61 |
- #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg]+ } |
|||
| 62 |
- #' function with tidying applied via [broom::tidy()].+ |
|||
| 63 |
- #' @param .stats (`character`)\cr the name of statistics to be reported among:+ #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the |
|||
| 64 |
- #' * `n`: number of observations (univariate only)+ #' interaction variable names and the given levels. The main value here is that the order |
|||
| 65 |
- #' * `hr`: hazard ratio+ #' of first and second variable is checked in the `interaction_vars` input. |
|||
| 66 |
- #' * `ci`: confidence interval+ #' |
|||
| 67 |
- #' * `pval`: p-value of the treatment effect+ #' @param interaction_vars (`character` of length 2)\cr interaction variable names. |
|||
| 68 |
- #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only)+ #' @param first_var_with_level (`character` of length 2)\cr the first variable name with |
|||
| 69 |
- #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model.+ #' the interaction level. |
|||
| 70 |
- #' Defaults to "all". Other options include "var_main" for main effects, `"inter"` for interaction effects,+ #' @param second_var_with_level (`character` of length 2)\cr the second variable name with |
|||
| 71 |
- #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is "all" specific+ #' the interaction level. |
|||
| 72 |
- #' variables can be selected by specifying `.var_nms`.+ #' |
|||
| 73 |
- #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically+ #' @return Name of coefficient. |
|||
| 74 |
- #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired+ #' |
|||
| 75 |
- #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars`+ #' @export |
|||
| 76 |
- #' is `"var_main"` `.var_nms` should be only the variable name.+ h_interaction_coef_name <- function(interaction_vars, |
|||
| 77 |
- #'+ first_var_with_level, |
|||
| 78 |
- #' @return+ second_var_with_level) {
|
|||
| 79 | -+ | 45x |
- #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s).+ checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE) |
|
| 80 | -+ | 45x |
- #'+ checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE) |
|
| 81 | -+ | 45x |
- #' @examples+ checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE) |
|
| 82 | -+ | 45x |
- #' # s_coxreg+ checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars) |
|
| 83 |
- #'+ |
|||
| 84 | -+ | 45x |
- #' # Univariate+ first_name <- paste(first_var_with_level, collapse = "") |
|
| 85 | -+ | 45x |
- #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder)+ second_name <- paste(second_var_with_level, collapse = "") |
|
| 86 | -+ | 45x |
- #' df1 <- broom::tidy(univar_model)+ if (first_var_with_level[1] == interaction_vars[1]) {
|
|
| 87 | -+ | 34x |
- #'+ paste(first_name, second_name, sep = ":") |
|
| 88 | -+ | 11x |
- #' s_coxreg(model_df = df1, .stats = "hr")+ } else if (second_var_with_level[1] == interaction_vars[1]) {
|
|
| 89 | -+ | 11x |
- #'+ paste(second_name, first_name, sep = ":") |
|
| 90 |
- #' # Univariate with interactions+ } |
|||
| 91 |
- #' univar_model_inter <- fit_coxreg_univar(+ } |
|||
| 92 |
- #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder+ |
|||
| 93 |
- #' )+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
|||
| 94 |
- #' df1_inter <- broom::tidy(univar_model_inter)+ #' for the case when both the odds ratio and the interaction variable are categorical. |
|||
| 96 |
- #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1")+ #' @param odds_ratio_var (`string`)\cr the odds ratio variable. |
|||
| 97 |
- #'+ #' @param interaction_var (`string`)\cr the interaction variable. |
|||
| 98 |
- #' # Univariate without treatment arm - only "COVAR2" covariate effects+ #' |
|||
| 99 |
- #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder)+ #' @return Odds ratio. |
|||
| 100 |
- #' df1_covs <- broom::tidy(univar_covs_model)+ #' |
|||
| 101 |
- #'+ #' @export |
|||
| 102 |
- #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
+ h_or_cat_interaction <- function(odds_ratio_var, |
|||
| 103 |
- #'+ interaction_var, |
|||
| 104 |
- #' # Multivariate.+ fit_glm, |
|||
| 105 |
- #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder)+ conf_level = 0.95) {
|
|||
| 106 | -+ | 7x |
- #' df2 <- broom::tidy(multivar_model)+ interaction_vars <- h_get_interaction_vars(fit_glm) |
|
| 107 | -+ | 7x |
- #'+ checkmate::assert_string(odds_ratio_var) |
|
| 108 | -+ | 7x |
- #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1")+ checkmate::assert_string(interaction_var) |
|
| 109 | -+ | 7x |
- #' s_coxreg(+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
|
| 110 | -+ | 7x |
- #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl",+ checkmate::assert_vector(interaction_vars, len = 2) |
|
| 111 |
- #' .var_nms = c("COVAR1", "A Covariate Label")
+
|
|||
| 112 | -+ | 7x |
- #' )+ xs_level <- fit_glm$xlevels |
|
| 113 | -+ | 7x |
- #'+ xs_coef <- stats::coef(fit_glm) |
|
| 114 | -+ | 7x |
- #' # Multivariate without treatment arm - only "COVAR1" main effect+ xs_vcov <- stats::vcov(fit_glm) |
|
| 115 | -+ | 7x |
- #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder)+ y <- list() |
|
| 116 | -+ | 7x |
- #' df2_covs <- broom::tidy(multivar_covs_model)+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
|
|
| 117 | -+ | 12x |
- #'+ x <- list() |
|
| 118 | -+ | 12x |
- #' s_coxreg(model_df = df2_covs, .stats = "hr")+ for (ref_level in xs_level[[interaction_var]]) {
|
|
| 119 | -+ | 32x |
- #'+ coef_names <- paste0(odds_ratio_var, var_level) |
|
| 120 | -+ | 32x |
- #' @export+ if (ref_level != xs_level[[interaction_var]][1]) {
|
|
| 121 | -+ | 20x |
- s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
+ interaction_coef_name <- h_interaction_coef_name( |
|
| 122 | -194x | +20x |
- assert_df_with_variables(model_df, list(term = "term", stat = .stats))+ interaction_vars, |
|
| 123 | -194x | +20x |
- checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
+ c(odds_ratio_var, var_level), |
|
| 124 | -194x | +20x |
- model_df$term <- as.character(model_df$term)+ c(interaction_var, ref_level) |
|
| 125 | -194x | +
- .var_nms <- .var_nms[!is.na(.var_nms)]+ ) |
||
| 126 | -+ | 20x |
-
+ coef_names <- c( |
|
| 127 | -192x | +20x |
- if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ]+ coef_names, |
|
| 128 | -39x | +20x |
- if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1)+ interaction_coef_name |
|
| 129 |
-
+ ) |
|||
| 130 |
- # We need a list with names corresponding to the stats to display of equal length to the list of stats.+ } |
|||
| 131 | -194x | +32x |
- y <- split(model_df, f = model_df$term, drop = FALSE)+ if (length(coef_names) > 1) {
|
|
| 132 | -194x | +20x |
- y <- stats::setNames(y, nm = rep(.stats, length(y)))+ ones <- t(c(1, 1)) |
|
| 133 | -+ | 20x |
-
+ est <- as.numeric(ones %*% xs_coef[coef_names]) |
|
| 134 | -194x | +20x |
- if (.which_vars == "var_main") {
+ se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones))) |
|
| 135 | -84x | +
- y <- lapply(y, function(x) x[1, ]) # only main effect+ } else {
|
||
| 136 | -110x | +12x |
- } else if (.which_vars %in% c("inter", "multi_lvl")) {
+ est <- xs_coef[coef_names] |
|
| 137 | -80x | +12x |
- y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
|
| 138 |
- }+ } |
|||
| 139 | -+ | 32x |
-
+ or <- exp(est) |
|
| 140 | -194x | +32x |
- lapply(+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
|
| 141 | -194x | +32x |
- X = y,+ x[[ref_level]] <- list(or = or, ci = ci) |
|
| 142 | -194x | +
- FUN = function(x) {
+ } |
||
| 143 | -198x | +12x |
- z <- as.list(x[[.stats]])+ y[[var_level]] <- x |
|
| 144 | -198x | +
- stats::setNames(z, nm = x$term_label)+ } |
||
| 145 | -+ | 7x |
- }+ y |
|
| 146 |
- )+ } |
|||
| 147 |
- }+ |
|||
| 148 |
-
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
|||
| 149 |
- #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()]+ #' for the case when either the odds ratio or the interaction variable is continuous. |
|||
| 150 |
- #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`.+ #' |
|||
| 151 |
- #'+ #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise |
|||
| 152 |
- #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`.+ #' the median is used. |
|||
| 153 |
- #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`.+ #' |
|||
| 154 |
- #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`.+ #' @return Odds ratio. |
|||
| 155 |
- #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to+ #' |
|||
| 156 |
- #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching).+ #' @note We don't provide a function for the case when both variables are continuous because |
|||
| 157 |
- #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed+ #' this does not arise in this table, as the treatment arm variable will always be involved |
|||
| 158 |
- #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing+ #' and categorical. |
|||
| 159 |
- #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding+ #' |
|||
| 160 |
- #' effect estimates will be tabulated later.+ #' @export |
|||
| 161 |
- #'+ h_or_cont_interaction <- function(odds_ratio_var, |
|||
| 162 |
- #' @return+ interaction_var, |
|||
| 163 |
- #' * `a_coxreg()` returns formatted [rtables::CellValue()].+ fit_glm, |
|||
| 164 |
- #'+ at = NULL, |
|||
| 165 |
- #' @examples+ conf_level = 0.95) {
|
|||
| 166 | -+ | 9x |
- #' a_coxreg(+ interaction_vars <- h_get_interaction_vars(fit_glm) |
|
| 167 | -+ | 9x |
- #' df = dta_bladder,+ checkmate::assert_string(odds_ratio_var) |
|
| 168 | -+ | 9x |
- #' labelstr = "Label 1",+ checkmate::assert_string(interaction_var) |
|
| 169 | -+ | 9x |
- #' variables = u1_variables,+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
|
| 170 | -+ | 9x |
- #' .spl_context = list(value = "COVAR1"),+ checkmate::assert_vector(interaction_vars, len = 2) |
|
| 171 | -+ | 9x |
- #' .stats = "n",+ checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
|
| 172 | -+ | 9x |
- #' .formats = "xx"+ xs_level <- fit_glm$xlevels |
|
| 173 | -+ | 9x |
- #' )+ xs_coef <- stats::coef(fit_glm) |
|
| 174 | -+ | 9x |
- #'+ xs_vcov <- stats::vcov(fit_glm) |
|
| 175 | -+ | 9x |
- #' a_coxreg(+ xs_class <- attr(fit_glm$terms, "dataClasses") |
|
| 176 | -+ | 9x |
- #' df = dta_bladder,+ model_data <- fit_glm$model |
|
| 177 | -+ | 9x |
- #' labelstr = "",+ if (!is.null(at)) {
|
|
| 178 | -+ | 2x |
- #' variables = u1_variables,+ checkmate::assert_set_equal(xs_class[interaction_var], "numeric") |
|
| 179 |
- #' .spl_context = list(value = "COVAR2"),+ } |
|||
| 180 | -+ | 9x |
- #' .stats = "pval",+ y <- list() |
|
| 181 | -+ | 9x |
- #' .formats = "xx.xxxx"+ if (xs_class[interaction_var] == "numeric") {
|
|
| 182 | -+ | 6x |
- #' )+ if (is.null(at)) {
|
|
| 183 | -+ | 4x |
- #'+ at <- ceiling(stats::median(model_data[[interaction_var]])) |
|
| 184 |
- #' @export+ } |
|||
| 185 |
- a_coxreg <- function(df,+ |
|||
| 186 | -+ | 6x |
- labelstr,+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
|
|
| 187 | -+ | 12x |
- eff = FALSE,+ x <- list() |
|
| 188 | -+ | 12x |
- var_main = FALSE,+ for (increment in at) {
|
|
| 189 | -+ | 18x |
- multivar = FALSE,+ coef_names <- paste0(odds_ratio_var, var_level) |
|
| 190 | -+ | 18x |
- variables,+ if (increment != 0) {
|
|
| 191 | -+ | 18x |
- at = list(),+ interaction_coef_name <- h_interaction_coef_name( |
|
| 192 | -+ | 18x |
- control = control_coxreg(),+ interaction_vars, |
|
| 193 | -+ | 18x |
- .spl_context,+ c(odds_ratio_var, var_level), |
|
| 194 | -+ | 18x |
- .stats,+ c(interaction_var, "") |
|
| 195 |
- .formats,+ ) |
|||
| 196 | -+ | 18x |
- .indent_mods = NULL,+ coef_names <- c( |
|
| 197 | -+ | 18x |
- na_level = lifecycle::deprecated(),+ coef_names, |
|
| 198 | -+ | 18x |
- na_str = "",+ interaction_coef_name |
|
| 199 |
- cache_env = NULL) {
+ ) |
|||
| 200 | -191x | +
- if (lifecycle::is_present(na_level)) {
+ } |
||
| 201 | -! | +18x |
- lifecycle::deprecate_warn("0.9.1", "a_coxreg(na_level)", "a_coxreg(na_str)")
+ if (length(coef_names) > 1) {
|
|
| 202 | -! | +18x |
- na_str <- na_level+ xvec <- t(c(1, increment)) |
|
| 203 | -+ | 18x |
- }+ est <- as.numeric(xvec %*% xs_coef[coef_names]) |
|
| 204 | -+ | 18x |
-
+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
|
| 205 | -191x | +
- cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm+ } else {
|
||
| 206 | -191x | +! |
- cov <- tail(.spl_context$value, 1) # current variable/covariate+ est <- xs_coef[coef_names] |
|
| 207 | -191x | +! |
- var_lbl <- formatters::var_labels(df)[cov] # check for df labels+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
|
| 208 | -191x | +
- if (length(labelstr) > 1) {
+ } |
||
| 209 | -! | +18x |
- labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none+ or <- exp(est) |
|
| 210 | -191x | +18x |
- } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
|
| 211 | -62x | +18x |
- labelstr <- var_lbl+ x[[as.character(increment)]] <- list(or = or, ci = ci) |
|
| 212 |
- }+ } |
|||
| 213 | -191x | +12x |
- if (eff || multivar || cov_no_arm) {
+ y[[var_level]] <- x |
|
| 214 | -82x | +
- control$interaction <- FALSE+ } |
||
| 216 | -109x | +3x |
- variables$covariates <- cov+ checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric") |
|
| 217 | -40x | +3x |
- if (var_main) control$interaction <- TRUE+ checkmate::assert_set_equal(xs_class[interaction_var], "factor") |
|
| 218 | -+ | 3x |
- }+ for (var_level in xs_level[[interaction_var]]) {
|
|
| 219 | -+ | 9x |
-
+ coef_names <- odds_ratio_var |
|
| 220 | -191x | +9x |
- if (is.null(cache_env[[cov]])) {
+ if (var_level != xs_level[[interaction_var]][1]) {
|
|
| 221 | -30x | +6x |
- if (!multivar) {
+ interaction_coef_name <- h_interaction_coef_name( |
|
| 222 | -23x | +6x |
- model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy()+ interaction_vars, |
|
| 223 | -+ | 6x |
- } else {
+ c(odds_ratio_var, ""), |
|
| 224 | -7x | +6x |
- model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy()+ c(interaction_var, var_level) |
|
| 225 |
- }+ ) |
|||
| 226 | -30x | +6x |
- cache_env[[cov]] <- model+ coef_names <- c( |
|
| 227 | -+ | 6x |
- } else {
+ coef_names, |
|
| 228 | -161x | +6x |
- model <- cache_env[[cov]]+ interaction_coef_name |
|
| 229 |
- }+ ) |
|||
| 230 | -109x | +
- if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_+ } |
||
| 231 | -+ | 9x |
-
+ if (length(coef_names) > 1) {
|
|
| 232 | -191x | +6x |
- if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
+ xvec <- t(c(1, 1)) |
|
| 233 | -15x | +6x |
- multivar <- TRUE+ est <- as.numeric(xvec %*% xs_coef[coef_names]) |
|
| 234 | -3x | +6x |
- if (!cov_no_arm) var_main <- TRUE+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
|
| 235 |
- }+ } else {
|
|||
| 236 | -+ | 3x |
-
+ est <- xs_coef[coef_names] |
|
| 237 | -191x | +3x |
- vars_coxreg <- list(which_vars = "all", var_nms = NULL)+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
|
| 238 | -191x | +
- if (eff) {
+ } |
||
| 239 | -40x | +9x |
- if (multivar && !var_main) { # multivar treatment level
+ or <- exp(est) |
|
| 240 | -6x | +9x |
- var_lbl_arm <- formatters::var_labels(df)[[variables$arm]]+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
|
| 241 | -6x | +9x |
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
+ y[[var_level]] <- list(or = or, ci = ci) |
|
| 242 |
- } else { # treatment effect
+ } |
|||
| 243 | -34x | +
- vars_coxreg["var_nms"] <- variables$arm+ } |
||
| 244 | -6x | +9x |
- if (var_main) vars_coxreg["which_vars"] <- "var_main"+ y |
|
| 245 |
- }+ } |
|||
| 246 |
- } else {
+
|
|||
| 247 | -151x | +
- if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 248 | -118x | +
- vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
+ #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and |
||
| 249 | -33x | +
- } else if (multivar) { # multivar covariate level
+ #' [h_or_cat_interaction()]. |
||
| 250 | -33x | +
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
+ #' |
||
| 251 | -6x | +
- if (var_main) model[cov, .stats] <- NA_real_+ #' @return Odds ratio. |
||
| 252 |
- }+ #' |
|||
| 253 | -40x | +
- if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect+ #' @export |
||
| 254 |
- }+ h_or_interaction <- function(odds_ratio_var, |
|||
| 255 | -191x | +
- var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]]+ interaction_var, |
||
| 256 | -191x | +
- var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
+ fit_glm, |
||
| 257 | -21x | +
- paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels+ at = NULL, |
||
| 258 | -191x | +
- } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) ||+ conf_level = 0.95) {
|
||
| 259 | -191x | +13x |
- (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
+ xs_class <- attr(fit_glm$terms, "dataClasses") |
|
| 260 | -47x | +13x |
- labelstr # other main effect labels+ if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
|
|
| 261 | -191x | +7x |
- } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
+ h_or_cont_interaction( |
|
| 262 | -6x | +7x |
- "All" # multivar numeric covariate+ odds_ratio_var, |
|
| 263 | -+ | 7x |
- } else {
+ interaction_var, |
|
| 264 | -117x | +7x |
- names(var_vals)+ fit_glm, |
|
| 265 | -+ | 7x |
- }+ at = at, |
|
| 266 | -191x | +7x |
- in_rows(+ conf_level = conf_level |
|
| 267 | -191x | +
- .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods,+ ) |
||
| 268 | -191x | +6x |
- .formats = stats::setNames(rep(.formats, length(var_names)), var_names),+ } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
|
|
| 269 | -191x | +6x |
- .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names)+ h_or_cat_interaction( |
|
| 270 | -+ | 6x |
- )+ odds_ratio_var, |
|
| 271 | -+ | 6x |
- }+ interaction_var, |
|
| 272 | -+ | 6x |
-
+ fit_glm, |
|
| 273 | -+ | 6x |
- #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table+ conf_level = conf_level |
|
| 274 |
- #' layout. This function is a wrapper for several `rtables` layouting functions. This function+ ) |
|||
| 275 |
- #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()].+ } else {
|
|||
| 276 | -+ | ! |
- #'+ stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
|
|
| 277 |
- #' @inheritParams fit_coxreg_univar+ } |
|||
| 278 |
- #' @param multivar (`flag`)\cr Defaults to `FALSE`. If `TRUE` multivariate Cox regression will run, otherwise+ } |
|||
| 279 |
- #' univariate Cox regression will run.+ |
|||
| 280 |
- #' @param common_var (`character`)\cr the name of a factor variable in the dataset which takes the same value+ #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table |
|||
| 281 |
- #' for all rows. This should be created during pre-processing if no such variable currently exists.+ #' of numbers of patients. |
|||
| 282 |
- #' @param .section_div (`character`)\cr string which should be repeated as a section divider between sections.+ #' |
|||
| 283 |
- #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between+ #' @param terms (`character`)\cr simple terms. |
|||
| 284 |
- #' treatment and covariate sections and the second between different covariates.+ #' @param table (`table`)\cr table containing numbers for terms. |
|||
| 286 |
- #' @return+ #' @return Term labels containing numbers of patients. |
|||
| 287 |
- #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions,+ #' |
|||
| 288 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table+ #' @export |
|||
| 289 |
- #' containing the chosen statistics to the table layout.+ h_simple_term_labels <- function(terms, |
|||
| 290 |
- #'+ table) {
|
|||
| 291 | -+ | 45x |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`,+ checkmate::assert_true(is.table(table)) |
|
| 292 | -+ | 45x |
- #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate+ checkmate::assert_multi_class(terms, classes = c("factor", "character"))
|
|
| 293 | -+ | 45x |
- #' Cox regression models, respectively.+ terms <- as.character(terms) |
|
| 294 | -+ | 45x |
- #'+ term_n <- table[terms] |
|
| 295 | -+ | 45x |
- #' @examples+ paste0(terms, ", n = ", term_n) |
|
| 296 |
- #' # summarize_coxreg+ } |
|||
| 297 |
- #'+ |
|||
| 298 |
- #' result_univar <- basic_table() %>%+ #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table |
|||
| 299 |
- #' summarize_coxreg(variables = u1_variables) %>%+ #' of numbers of patients. |
|||
| 300 |
- #' build_table(dta_bladder)+ #' |
|||
| 301 |
- #' result_univar+ #' @param terms1 (`character`)\cr terms for first dimension (rows). |
|||
| 302 |
- #'+ #' @param terms2 (`character`)\cr terms for second dimension (rows). |
|||
| 303 |
- #' result_univar_covs <- basic_table() %>%+ #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the |
|||
| 304 |
- #' summarize_coxreg(+ #' number of patients. In that case they can only be scalar (strings). |
|||
| 305 |
- #' variables = u2_variables,+ #' |
|||
| 306 |
- #' ) %>%+ #' @return Term labels containing numbers of patients. |
|||
| 307 |
- #' build_table(dta_bladder)+ #' |
|||
| 308 |
- #' result_univar_covs+ #' @export |
|||
| 309 |
- #'+ h_interaction_term_labels <- function(terms1, |
|||
| 310 |
- #' result_multivar <- basic_table() %>%+ terms2, |
|||
| 311 |
- #' summarize_coxreg(+ table, |
|||
| 312 |
- #' variables = m1_variables,+ any = FALSE) {
|
|||
| 313 | +8x | +
+ checkmate::assert_true(is.table(table))+ |
+ ||
| 314 | +8x | +
+ checkmate::assert_flag(any)+ |
+ ||
| 315 | +8x | +
+ checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ |
+ ||
| 316 | +8x | +
+ checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ |
+ ||
| 317 | +8x | +
+ terms1 <- as.character(terms1)+ |
+ ||
| 318 | +8x | +
+ terms2 <- as.character(terms2)+ |
+ ||
| 319 | +8x | +
+ if (any) {
+ |
+ ||
| 320 | +4x | +
+ checkmate::assert_scalar(terms1)+ |
+ ||
| 321 | +4x | +
+ checkmate::assert_scalar(terms2)+ |
+ ||
| 322 | +4x | +
+ paste0(+ |
+ ||
| 323 | +4x | +
+ terms1, " or ", terms2, ", n = ",+ |
+ ||
| 324 |
- #' multivar = TRUE,+ # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.+ |
+ |||
| 325 | +4x | +
+ sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2] |
||
| 314 | +326 |
- #' ) %>%+ ) |
||
| 315 | +327 |
- #' build_table(dta_bladder)+ } else {
+ |
+ ||
| 328 | +4x | +
+ term_n <- table[cbind(terms1, terms2)]+ |
+ ||
| 329 | +4x | +
+ paste0(terms1, " * ", terms2, ", n = ", term_n) |
||
| 316 | +330 |
- #' result_multivar+ } |
||
| 317 | +331 |
- #'+ } |
||
| 318 | +332 |
- #' result_multivar_covs <- basic_table() %>%+ |
||
| 319 | +333 |
- #' summarize_coxreg(+ #' @describeIn h_logistic_regression Helper function to tabulate the main effect |
||
| 320 | +334 |
- #' variables = m2_variables,+ #' results of a (conditional) logistic regression model. |
||
| 321 | +335 |
- #' multivar = TRUE,+ #' |
||
| 322 | +336 |
- #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
+ #' @return Tabulated main effect results from a logistic regression model. |
||
| 323 | +337 |
- #' ) %>%+ #' |
||
| 324 | +338 |
- #' build_table(dta_bladder)+ #' @examples |
||
| 325 | +339 |
- #' result_multivar_covs+ #' h_glm_simple_term_extract("AGE", mod1)
|
||
| 326 | +340 | ++ |
+ #' h_glm_simple_term_extract("ARMCD", mod1)
+ |
+ |
| 341 |
#' |
|||
| 327 | +342 | ++ |
+ #' @export+ |
+ |
| 343 | ++ |
+ h_glm_simple_term_extract <- function(x, fit_glm) {
+ |
+ ||
| 344 | +73x | +
+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ |
+ ||
| 345 | +73x | +
+ checkmate::assert_string(x)+ |
+ ||
| 346 | ++ | + + | +||
| 347 | +73x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+ ||
| 348 | +73x | +
+ xs_level <- fit_glm$xlevels+ |
+ ||
| 349 | +73x | +
+ xs_coef <- summary(fit_glm)$coefficients+ |
+ ||
| 350 | +73x | +
+ stats <- if (inherits(fit_glm, "glm")) {
+ |
+ ||
| 351 | +61x | +
+ c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ |
+ ||
| 352 | ++ |
+ } else {
+ |
+ ||
| 353 | +12x | +
+ c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ |
+ ||
| 354 | ++ |
+ }+ |
+ ||
| 355 | ++ |
+ # Make sure x is not an interaction term.+ |
+ ||
| 356 | +73x | +
+ checkmate::assert_subset(x, names(xs_class))+ |
+ ||
| 357 | +73x | +
+ x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ |
+ ||
| 358 | +73x | +
+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ |
+ ||
| 359 | +73x | +
+ colnames(x_stats) <- names(stats)+ |
+ ||
| 360 | +73x | +
+ x_stats$estimate <- as.list(x_stats$estimate)+ |
+ ||
| 361 | +73x | +
+ x_stats$std_error <- as.list(x_stats$std_error)+ |
+ ||
| 362 | +73x | +
+ x_stats$pvalue <- as.list(x_stats$pvalue)+ |
+ ||
| 363 | +73x | +
+ x_stats$df <- as.list(1)+ |
+ ||
| 364 | +73x | +
+ if (xs_class[x] == "numeric") {
+ |
+ ||
| 365 | +58x | +
+ x_stats$term <- x+ |
+ ||
| 366 | +58x | +
+ x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ |
+ ||
| 367 | +46x | +
+ formatters::var_labels(fit_glm$data[x], fill = TRUE)+ |
+ ||
| 368 | ++ |
+ } else {
+ |
+ ||
| 369 | ++ |
+ # We just fill in here with the `term` itself as we don't have the data available.+ |
+ ||
| 370 | +12x | +
+ x+ |
+ ||
| 371 | ++ |
+ }+ |
+ ||
| 372 | +58x | +
+ x_stats$is_variable_summary <- FALSE+ |
+ ||
| 373 | +58x | +
+ x_stats$is_term_summary <- TRUE+ |
+ ||
| 374 | ++ |
+ } else {
+ |
+ ||
| 375 | +15x | +
+ checkmate::assert_class(fit_glm, "glm")+ |
+ ||
| 376 | ++ |
+ # The reason is that we don't have the original data set in the `clogit` object+ |
+ ||
| 377 | ++ |
+ # and therefore cannot determine the `x_numbers` here.+ |
+ ||
| 378 | +15x | +
+ x_numbers <- table(fit_glm$data[[x]])+ |
+ ||
| 379 | +15x | +
+ x_stats$term <- xs_level[[x]][-1]+ |
+ ||
| 380 | +15x | +
+ x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ |
+ ||
| 381 | +15x | +
+ x_stats$is_variable_summary <- FALSE+ |
+ ||
| 382 | +15x | +
+ x_stats$is_term_summary <- TRUE+ |
+ ||
| 383 | +15x | +
+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ |
+ ||
| 384 | +15x | +
+ x_main <- data.frame(+ |
+ ||
| 385 | +15x | +
+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ |
+ ||
| 386 | +15x | +
+ term = xs_level[[x]][1],+ |
+ ||
| 387 | +15x | +
+ term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ |
+ ||
| 388 | +15x | +
+ df = main_effects[x, "Df", drop = TRUE],+ |
+ ||
| 389 | +15x | +
+ stringsAsFactors = FALSE+ |
+ ||
| 390 | ++ |
+ )+ |
+ ||
| 391 | +15x | +
+ x_main$pvalue <- as.list(x_main$pvalue)+ |
+ ||
| 392 | +15x | +
+ x_main$df <- as.list(x_main$df)+ |
+ ||
| 393 | +15x | +
+ x_main$estimate <- list(numeric(0))+ |
+ ||
| 394 | +15x | +
+ x_main$std_error <- list(numeric(0))+ |
+ ||
| 395 | +15x | +
+ if (length(xs_level[[x]][-1]) == 1) {
+ |
+ ||
| 396 | +6x | +
+ x_main$pvalue <- list(numeric(0))+ |
+ ||
| 397 | +6x | +
+ x_main$df <- list(numeric(0))+ |
+ ||
| 398 | ++ |
+ }+ |
+ ||
| 399 | +15x | +
+ x_main$is_variable_summary <- TRUE+ |
+ ||
| 400 | +15x | +
+ x_main$is_term_summary <- FALSE+ |
+ ||
| 401 | +15x | +
+ x_stats <- rbind(x_main, x_stats)+ |
+ ||
| 402 | ++ |
+ }+ |
+ ||
| 403 | +73x | +
+ x_stats$variable <- x+ |
+ ||
| 404 | +73x | +
+ x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
+ |
+ ||
| 405 | +61x | +
+ formatters::var_labels(fit_glm$data[x], fill = TRUE)+ |
+ ||
| 406 | ++ |
+ } else {
+ |
+ ||
| 407 | +12x | +
+ x+ |
+ ||
| 408 | ++ |
+ }+ |
+ ||
| 409 | +73x | +
+ x_stats$interaction <- ""+ |
+ ||
| 410 | +73x | +
+ x_stats$interaction_label <- ""+ |
+ ||
| 411 | +73x | +
+ x_stats$reference <- ""+ |
+ ||
| 412 | +73x | +
+ x_stats$reference_label <- ""+ |
+ ||
| 413 | +73x | +
+ rownames(x_stats) <- NULL+ |
+ ||
| 414 | +73x | +
+ x_stats[c(+ |
+ ||
| 415 | +73x | +
+ "variable",+ |
+ ||
| 416 | +73x | +
+ "variable_label",+ |
+ ||
| 417 | +73x | +
+ "term",+ |
+ ||
| 418 | +73x | +
+ "term_label",+ |
+ ||
| 419 | +73x | +
+ "interaction",+ |
+ ||
| 420 | +73x | +
+ "interaction_label",+ |
+ ||
| 421 | +73x | +
+ "reference",+ |
+ ||
| 422 | +73x | +
+ "reference_label",+ |
+ ||
| 423 | +73x | +
+ "estimate",+ |
+ ||
| 424 | +73x | +
+ "std_error",+ |
+ ||
| 425 | +73x | +
+ "df",+ |
+ ||
| 426 | +73x | +
+ "pvalue",+ |
+ ||
| 427 | +73x | +
+ "is_variable_summary",+ |
+ ||
| 428 | +73x | +
+ "is_term_summary"+ |
+ ||
| 429 | ++ |
+ )]+ |
+ ||
| 430 | ++ |
+ }+ |
+ ||
| 431 | ++ | + + | +||
| 432 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction term+ |
+ ||
| 433 | ++ |
+ #' results of a logistic regression model.+ |
+ ||
| 434 | ++ |
+ #'+ |
+ ||
| 435 | ++ |
+ #' @return Tabulated interaction term results from a logistic regression model.+ |
+ ||
| 436 | ++ |
+ #'+ |
+ ||
| 437 | ++ |
+ #' @examples+ |
+ ||
| 438 | ++ |
+ #' h_glm_interaction_extract("ARMCD:AGE", mod2)
+ |
+ ||
| 439 | ++ |
+ #'+ |
+ ||
| 440 | ++ |
+ #' @export+ |
+ ||
| 441 | ++ |
+ h_glm_interaction_extract <- function(x, fit_glm) {
+ |
+ ||
| 442 | +6x | +
+ vars <- h_get_interaction_vars(fit_glm)+ |
+ ||
| 443 | +6x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+ ||
| 444 | ++ | + + | +||
| 445 | +6x | +
+ checkmate::assert_string(x)+ |
+ ||
| 446 | ++ | + + | +||
| 447 | ++ |
+ # Only take two-way interaction+ |
+ ||
| 448 | +6x | +
+ checkmate::assert_vector(vars, len = 2)+ |
+ ||
| 449 | ++ | + + | +||
| 450 | ++ |
+ # Only consider simple case: first variable in interaction is arm, a categorical variable+ |
+ ||
| 451 | +6x | +
+ checkmate::assert_disjunct(xs_class[vars[1]], "numeric")+ |
+ ||
| 452 | ++ | + + | +||
| 453 | +6x | +
+ xs_level <- fit_glm$xlevels+ |
+ ||
| 454 | +6x | +
+ xs_coef <- summary(fit_glm)$coefficients+ |
+ ||
| 455 | +6x | +
+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ |
+ ||
| 456 | +6x | +
+ stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ |
+ ||
| 457 | +6x | +
+ v1_comp <- xs_level[[vars[1]]][-1]+ |
+ ||
| 458 | +6x | +
+ if (xs_class[vars[2]] == "numeric") {
+ |
+ ||
| 459 | +3x | +
+ x_stats <- as.data.frame(+ |
+ ||
| 460 | +3x | +
+ xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],+ |
+ ||
| 461 | +3x | +
+ stringsAsFactors = FALSE+ |
+ ||
| 462 | ++ |
+ )+ |
+ ||
| 463 | +3x | +
+ colnames(x_stats) <- names(stats)+ |
+ ||
| 464 | +3x | +
+ x_stats$term <- v1_comp+ |
+ ||
| 465 | +3x | +
+ x_numbers <- table(fit_glm$data[[vars[1]]])+ |
+ ||
| 466 | +3x | +
+ x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)+ |
+ ||
| 467 | +3x | +
+ v1_ref <- xs_level[[vars[1]]][1]+ |
+ ||
| 468 | +3x | +
+ term_main <- v1_ref+ |
+ ||
| 469 | +3x | +
+ ref_label <- h_simple_term_labels(v1_ref, x_numbers)+ |
+ ||
| 470 | +3x | +
+ } else if (xs_class[vars[2]] != "numeric") {
+ |
+ ||
| 471 | +3x | +
+ v2_comp <- xs_level[[vars[2]]][-1]+ |
+ ||
| 472 | +3x | +
+ v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ |
+ ||
| 473 | +3x | +
+ x_sel <- paste(+ |
+ ||
| 474 | +3x | +
+ paste0(vars[1], v1_v2_grid$v1),+ |
+ ||
| 475 | +3x | +
+ paste0(vars[2], v1_v2_grid$v2),+ |
+ ||
| 476 | +3x | +
+ sep = ":"+ |
+ ||
| 477 | ++ |
+ )+ |
+ ||
| 478 | +3x | +
+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ |
+ ||
| 479 | +3x | +
+ colnames(x_stats) <- names(stats)+ |
+ ||
| 480 | +3x | +
+ x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2)+ |
+ ||
| 481 | +3x | +
+ x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]])+ |
+ ||
| 482 | +3x | +
+ x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers)+ |
+ ||
| 483 | +3x | +
+ v1_ref <- xs_level[[vars[1]]][1]+ |
+ ||
| 484 | +3x | +
+ v2_ref <- xs_level[[vars[2]]][1]+ |
+ ||
| 485 | +3x | +
+ term_main <- paste(vars[1], vars[2], sep = " * ")+ |
+ ||
| 486 | +3x | +
+ ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)+ |
+ ||
| 487 | ++ |
+ }+ |
+ ||
| 488 | +6x | +
+ x_stats$df <- as.list(1)+ |
+ ||
| 489 | +6x | +
+ x_stats$pvalue <- as.list(x_stats$pvalue)+ |
+ ||
| 490 | +6x | +
+ x_stats$is_variable_summary <- FALSE+ |
+ ||
| 491 | +6x | +
+ x_stats$is_term_summary <- TRUE+ |
+ ||
| 492 | +6x | +
+ x_main <- data.frame(+ |
+ ||
| 493 | +6x | +
+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ |
+ ||
| 494 | +6x | +
+ term = term_main,+ |
+ ||
| 495 | +6x | +
+ term_label = paste("Reference", ref_label),
+ |
+ ||
| 496 | +6x | +
+ df = main_effects[x, "Df", drop = TRUE],+ |
+ ||
| 497 | +6x | +
+ stringsAsFactors = FALSE+ |
+ ||
| 498 | ++ |
+ )+ |
+ ||
| 499 | +6x | +
+ x_main$pvalue <- as.list(x_main$pvalue)+ |
+ ||
| 500 | +6x | +
+ x_main$df <- as.list(x_main$df)+ |
+ ||
| 501 | +6x | +
+ x_main$estimate <- list(numeric(0))+ |
+ ||
| 502 | +6x | +
+ x_main$std_error <- list(numeric(0))+ |
+ ||
| 503 | +6x | +
+ x_main$is_variable_summary <- TRUE+ |
+ ||
| 504 | +6x | +
+ x_main$is_term_summary <- FALSE+ |
+ ||
| 505 | ++ | + + | +||
| 506 | +6x | +
+ x_stats <- rbind(x_main, x_stats)+ |
+ ||
| 507 | +6x | +
+ x_stats$variable <- x+ |
+ ||
| 508 | +6x | +
+ x_stats$variable_label <- paste(+ |
+ ||
| 509 | +6x | +
+ "Interaction of",+ |
+ ||
| 510 | +6x | +
+ formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE),+ |
+ ||
| 511 | ++ |
+ "*",+ |
+ ||
| 512 | +6x | +
+ formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE)+ |
+ ||
| 513 | ++ |
+ )+ |
+ ||
| 514 | +6x | +
+ x_stats$interaction <- ""+ |
+ ||
| 515 | +6x | +
+ x_stats$interaction_label <- ""+ |
+ ||
| 516 | +6x | +
+ x_stats$reference <- ""+ |
+ ||
| 517 | +6x | +
+ x_stats$reference_label <- ""+ |
+ ||
| 518 | +6x | +
+ rownames(x_stats) <- NULL+ |
+ ||
| 519 | +6x | +
+ x_stats[c(+ |
+ ||
| 520 | +6x | +
+ "variable",+ |
+ ||
| 521 | +6x | +
+ "variable_label",+ |
+ ||
| 522 | +6x | +
+ "term",+ |
+ ||
| 523 | +6x | +
+ "term_label",+ |
+ ||
| 524 | +6x | +
+ "interaction",+ |
+ ||
| 525 | +6x | +
+ "interaction_label",+ |
+ ||
| 526 | +6x | +
+ "reference",+ |
+ ||
| 527 | +6x | +
+ "reference_label",+ |
+ ||
| 528 | +6x | +
+ "estimate",+ |
+ ||
| 529 | +6x | +
+ "std_error",+ |
+ ||
| 530 | +6x | +
+ "df",+ |
+ ||
| 531 | +6x | +
+ "pvalue",+ |
+ ||
| 532 | +6x | +
+ "is_variable_summary",+ |
+ ||
| 533 | +6x | +
+ "is_term_summary"+ |
+ ||
| 534 | ++ |
+ )]+ |
+ ||
| 535 | ++ |
+ }+ |
+ ||
| 536 | ++ | + + | +||
| 537 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction+ |
+ ||
| 538 | ++ |
+ #' results of a logistic regression model. This basically is a wrapper for+ |
+ ||
| 539 | ++ |
+ #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results+ |
+ ||
| 540 | ++ |
+ #' in the right data frame format.+ |
+ ||
| 541 | ++ |
+ #'+ |
+ ||
| 542 | ++ |
+ #' @return A `data.frame` of tabulated interaction term results from a logistic regression model.+ |
+ ||
| 543 | ++ |
+ #'+ |
+ ||
| 544 | ++ |
+ #' @examples+ |
+ ||
| 545 | ++ |
+ #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
+ |
+ ||
| 546 | ++ |
+ #'+ |
+ ||
| 547 | ++ |
+ #' @export+ |
+ ||
| 548 | ++ |
+ h_glm_inter_term_extract <- function(odds_ratio_var,+ |
+ ||
| 549 | ++ |
+ interaction_var,+ |
+ ||
| 550 | ++ |
+ fit_glm,+ |
+ ||
| 551 | ++ |
+ ...) {
+ |
+ ||
| 552 | ++ |
+ # First obtain the main effects.+ |
+ ||
| 553 | +11x | +
+ main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm)+ |
+ ||
| 554 | +11x | +
+ main_stats$is_reference_summary <- FALSE+ |
+ ||
| 555 | +11x | +
+ main_stats$odds_ratio <- NA+ |
+ ||
| 556 | +11x | +
+ main_stats$lcl <- NA+ |
+ ||
| 557 | +11x | +
+ main_stats$ucl <- NA+ |
+ ||
| 558 | ++ | + + | +||
| 559 | ++ |
+ # Then we get the odds ratio estimates and put into df form.+ |
+ ||
| 560 | +11x | +
+ or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...)+ |
+ ||
| 561 | +11x | +
+ is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric"+ |
+ ||
| 562 | ++ | + + | +||
| 563 | +11x | +
+ if (is_num_or_var) {
+ |
+ ||
| 564 | ++ |
+ # Numeric OR variable case.+ |
+ ||
| 565 | +3x | +
+ references <- names(or_numbers)+ |
+ ||
| 566 | +3x | +
+ n_ref <- length(references)+ |
+ ||
| 567 | ++ | + + | +||
| 568 | +3x | +
+ extract_from_list <- function(l, name, pos = 1) {
+ |
+ ||
| 569 | +9x | +
+ unname(unlist(+ |
+ ||
| 570 | +9x | +
+ lapply(or_numbers, function(x) {
+ |
+ ||
| 571 | +27x | +
+ x[[name]][pos]+ |
+ ||
| 572 | ++ |
+ })+ |
+ ||
| 573 | ++ |
+ ))+ |
+ ||
| 574 | ++ |
+ }+ |
+ ||
| 575 | +3x | +
+ or_stats <- data.frame(+ |
+ ||
| 576 | +3x | +
+ variable = odds_ratio_var,+ |
+ ||
| 577 | +3x | +
+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ |
+ ||
| 578 | +3x | +
+ term = odds_ratio_var,+ |
+ ||
| 579 | +3x | +
+ term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ |
+ ||
| 580 | +3x | +
+ interaction = interaction_var,+ |
+ ||
| 581 | +3x | +
+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ |
+ ||
| 582 | +3x | +
+ reference = references,+ |
+ ||
| 583 | +3x | +
+ reference_label = references,+ |
+ ||
| 584 | +3x | +
+ estimate = NA,+ |
+ ||
| 585 | +3x | +
+ std_error = NA,+ |
+ ||
| 586 | +3x | +
+ odds_ratio = extract_from_list(or_numbers, "or"),+ |
+ ||
| 587 | +3x | +
+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ |
+ ||
| 588 | +3x | +
+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ |
+ ||
| 589 | +3x | +
+ df = NA,+ |
+ ||
| 590 | +3x | +
+ pvalue = NA,+ |
+ ||
| 591 | +3x | +
+ is_variable_summary = FALSE,+ |
+ ||
| 592 | +3x | +
+ is_term_summary = FALSE,+ |
+ ||
| 593 | +3x | +
+ is_reference_summary = TRUE+ |
+ ||
| 594 | ++ |
+ )+ |
+ ||
| 595 | ++ |
+ } else {
+ |
+ ||
| 596 | ++ |
+ # Categorical OR variable case.+ |
+ ||
| 597 | +8x | +
+ references <- names(or_numbers[[1]])+ |
+ ||
| 598 | +8x | +
+ n_ref <- length(references)+ |
+ ||
| 599 | ++ | + + | +||
| 600 | +8x | +
+ extract_from_list <- function(l, name, pos = 1) {
+ |
+ ||
| 601 | +24x | +
+ unname(unlist(+ |
+ ||
| 602 | +24x | +
+ lapply(or_numbers, function(x) {
+ |
+ ||
| 603 | +42x | +
+ lapply(x, function(y) y[[name]][pos])+ |
+ ||
| 604 | ++ |
+ })+ |
+ ||
| 605 | ++ |
+ ))+ |
+ ||
| 606 | ++ |
+ }+ |
+ ||
| 607 | +8x | +
+ or_stats <- data.frame(+ |
+ ||
| 608 | +8x | +
+ variable = odds_ratio_var,+ |
+ ||
| 609 | +8x | +
+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ |
+ ||
| 610 | +8x | +
+ term = rep(names(or_numbers), each = n_ref),+ |
+ ||
| 611 | +8x | +
+ term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])),+ |
+ ||
| 612 | +8x | +
+ interaction = interaction_var,+ |
+ ||
| 613 | +8x | +
+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ |
+ ||
| 614 | +8x | +
+ reference = unlist(lapply(or_numbers, names)),+ |
+ ||
| 615 | +8x | +
+ reference_label = unlist(lapply(or_numbers, names)),+ |
+ ||
| 616 | +8x | +
+ estimate = NA,+ |
+ ||
| 617 | +8x | +
+ std_error = NA,+ |
+ ||
| 618 | +8x | +
+ odds_ratio = extract_from_list(or_numbers, "or"),+ |
+ ||
| 619 | +8x | +
+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ |
+ ||
| 620 | +8x | +
+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ |
+ ||
| 621 | +8x | +
+ df = NA,+ |
+ ||
| 622 | +8x | +
+ pvalue = NA,+ |
+ ||
| 623 | +8x | +
+ is_variable_summary = FALSE,+ |
+ ||
| 624 | +8x | +
+ is_term_summary = FALSE,+ |
+ ||
| 625 | +8x | +
+ is_reference_summary = TRUE+ |
+ ||
| 626 | ++ |
+ )+ |
+ ||
| 627 | ++ |
+ }+ |
+ ||
| 628 |
- #' @export+ |
|||
| 328 | -+ | |||
| 629 | +11x |
- #' @order 2+ df <- rbind( |
||
| 329 | -+ | |||
| 630 | +11x |
- summarize_coxreg <- function(lyt,+ main_stats[, names(or_stats)], |
||
| 330 | -+ | |||
| 631 | +11x |
- variables,+ or_stats |
||
| 331 | +632 |
- control = control_coxreg(),+ ) |
||
| 332 | -+ | |||
| 633 | +11x |
- at = list(),+ df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ] |
||
| 333 | +634 |
- multivar = FALSE,+ } |
||
| 334 | +635 |
- common_var = "STUDYID",+ |
||
| 335 | +636 |
- .stats = c("n", "hr", "ci", "pval", "pval_inter"),
+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
||
| 336 | +637 |
- .formats = c(+ #' odds ratios and confidence intervals of simple terms. |
||
| 337 | +638 |
- n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)",+ #' |
||
| 338 | +639 |
- pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)"+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
||
| 339 | +640 |
- ),+ #' |
||
| 340 | +641 |
- varlabels = NULL,+ #' @examples |
||
| 341 | +642 |
- .indent_mods = NULL,+ #' h_logistic_simple_terms("AGE", mod1)
|
||
| 342 | +643 |
- na_level = lifecycle::deprecated(),+ #' |
||
| 343 | +644 |
- na_str = "",+ #' @export |
||
| 344 | +645 |
- .section_div = NA_character_) {
+ h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
|
||
| 345 | -11x | +646 | +52x |
- if (lifecycle::is_present(na_level)) {
+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
|
| 346 | -! | +|||
| 647 | +52x |
- lifecycle::deprecate_warn("0.9.1", "summarize_coxreg(na_level)", "summarize_coxreg(na_str)")
+ if (inherits(fit_glm, "glm")) {
|
||
| 347 | -! | +|||
| 648 | +41x |
- na_str <- na_level+ checkmate::assert_set_equal(fit_glm$family$family, "binomial") |
||
| 348 | +649 |
} |
||
| 349 | -- | - - | -||
| 350 | -11x | +650 | +52x |
- if (multivar && control$interaction) {
+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
| 351 | -1x | +651 | +52x |
- warning(paste(+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 352 | -1x | +652 | +52x |
- "Interactions are not available for multivariate cox regression using summarize_coxreg.",+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
| 353 | -1x | +653 | +52x |
- "The model will be calculated without interaction effects."+ checkmate::assert_subset(x, terms_name) |
| 354 | -+ | |||
| 654 | +52x |
- ))+ if (length(interaction) != 0) {
|
||
| 355 | +655 |
- }- |
- ||
| 356 | -11x | -
- if (control$interaction && !"arm" %in% names(variables)) {
+ # Make sure any item in x is not part of interaction term |
||
| 357 | +656 | 1x |
- stop("To include interactions please specify 'arm' in variables.")
+ checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":"))) |
|
| 358 | +657 |
} |
||
| 359 | -- | - - | -||
| 360 | -10x | +658 | +52x |
- .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
+ x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm) |
| 361 | -4x | +659 | +52x |
- intersect(c("hr", "ci", "pval"), .stats)
+ x_stats <- do.call(rbind, x_stats) |
| 362 | -10x | +660 | +52x |
- } else if (control$interaction) {
+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 363 | -4x | -
- intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
- |
- ||
| 364 | -+ | 661 | +52x |
- } else {
+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
| 365 | -2x | +662 | +52x |
- intersect(c("n", "hr", "ci", "pval"), .stats)
+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 366 | -+ | |||
| 663 | +52x |
- }+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
||
| 367 | -10x | +664 | +52x |
- stat_labels <- c(+ x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl) |
| 368 | -10x | +665 | +52x |
- n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),+ x_stats |
| 369 | -10x | +|||
| 666 | +
- pval = "p-value", pval_inter = "Interaction p-value"+ } |
|||
| 370 | +667 |
- )+ |
||
| 371 | -10x | +|||
| 668 | +
- stat_labels <- stat_labels[names(stat_labels) %in% .stats]+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
|||
| 372 | -10x | +|||
| 669 | +
- .formats <- .formats[names(.formats) %in% .stats]+ #' odds ratios and confidence intervals of interaction terms. |
|||
| 373 | -10x | +|||
| 670 | +
- env <- new.env() # create caching environment+ #' |
|||
| 374 | +671 |
-
+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
||
| 375 | -10x | +|||
| 672 | +
- lyt <- lyt %>%+ #' |
|||
| 376 | -10x | +|||
| 673 | +
- split_cols_by_multivar(+ #' @examples |
|||
| 377 | -10x | +|||
| 674 | +
- vars = rep(common_var, length(.stats)),+ #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
|
|||
| 378 | -10x | +|||
| 675 | +
- varlabels = stat_labels,+ #' |
|||
| 379 | -10x | +|||
| 676 | +
- extra_args = list(+ #' @export |
|||
| 380 | -10x | +|||
| 677 | +
- .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)),+ h_logistic_inter_terms <- function(x, |
|||
| 381 | -10x | +|||
| 678 | +
- cache_env = replicate(length(.stats), list(env))+ fit_glm, |
|||
| 382 | +679 |
- )+ conf_level = 0.95, |
||
| 383 | +680 |
- )+ at = NULL) {
|
||
| 384 | +681 |
-
+ # Find out the interaction variables and interaction term. |
||
| 385 | -10x | +682 | +4x |
- if ("arm" %in% names(variables)) { # treatment effect
+ inter_vars <- h_get_interaction_vars(fit_glm) |
| 386 | -8x | +683 | +4x |
- lyt <- lyt %>%+ checkmate::assert_vector(inter_vars, len = 2) |
| 387 | -8x | +|||
| 684 | +
- split_rows_by(+ |
|||
| 388 | -8x | +|||
| 685 | +
- common_var,+ |
|||
| 389 | -8x | +686 | +4x |
- split_label = "Treatment:",+ inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x)) |
| 390 | -8x | +687 | +4x |
- label_pos = "visible",+ inter_term <- x[inter_term_index] |
| 391 | -8x | +|||
| 688 | +
- child_labels = "hidden",+ + |
+ |||
| 689 | ++ |
+ # For the non-interaction vars we need the standard stuff. |
||
| 392 | -8x | +690 | +4x |
- section_div = head(.section_div, 1)+ normal_terms <- setdiff(x, union(inter_vars, inter_term)) |
| 393 | +691 |
- )+ |
||
| 394 | -8x | +692 | +4x |
- if (!multivar) {
+ x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm) |
| 395 | -6x | +693 | +4x |
- lyt <- lyt %>%+ x_stats <- do.call(rbind, x_stats) |
| 396 | -6x | +694 | +4x |
- analyze_colvars(+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 397 | -6x | +695 | +4x |
- afun = a_coxreg,+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
| 398 | -6x | +696 | +4x |
- na_str = na_str,+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 399 | -6x | +697 | +4x |
- extra_args = list(+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 400 | -6x | +698 | +4x |
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar,+ normal_stats <- x_stats |
| 401 | -6x | +699 | +4x |
- labelstr = ""+ normal_stats$is_reference_summary <- FALSE |
| 402 | +700 |
- )+ |
||
| 403 | +701 |
- )+ # Now the interaction term itself. |
||
| 404 | -+ | |||
| 702 | +4x |
- } else { # treatment level effects
+ inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm) |
||
| 405 | -2x | +703 | +4x |
- lyt <- lyt %>%+ inter_term_stats$odds_ratio <- NA |
| 406 | -2x | +704 | +4x |
- summarize_row_groups(+ inter_term_stats$lcl <- NA |
| 407 | -2x | +705 | +4x |
- cfun = a_coxreg,+ inter_term_stats$ucl <- NA |
| 408 | -2x | +706 | +4x |
- na_str = na_str,+ inter_term_stats$is_reference_summary <- FALSE |
| 409 | -2x | +|||
| 707 | +
- extra_args = list(+ |
|||
| 410 | -2x | +708 | +4x |
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar+ is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric" |
| 411 | +709 |
- )+ |
||
| 412 | +710 |
- ) %>%+ # Interaction stuff. |
||
| 413 | -2x | +711 | +4x |
- analyze_colvars(+ inter_stats_one <- h_glm_inter_term_extract( |
| 414 | -2x | +712 | +4x |
- afun = a_coxreg,+ inter_vars[1], |
| 415 | -2x | +713 | +4x |
- na_str = na_str,+ inter_vars[2], |
| 416 | -2x | -
- extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "")- |
- ||
| 417 | -+ | 714 | +4x |
- )+ fit_glm, |
| 418 | -+ | |||
| 715 | +4x |
- }+ conf_level = conf_level, |
||
| 419 | -+ | |||
| 716 | +4x |
- }+ at = `if`(is_intervar1_numeric, NULL, at) |
||
| 420 | +717 | - - | -||
| 421 | -10x | -
- if ("covariates" %in% names(variables)) { # covariate main effects
+ ) |
||
| 422 | -10x | +718 | +4x |
- lyt <- lyt %>%+ inter_stats_two <- h_glm_inter_term_extract( |
| 423 | -10x | +719 | +4x |
- split_rows_by_multivar(+ inter_vars[2], |
| 424 | -10x | +720 | +4x |
- vars = variables$covariates,+ inter_vars[1], |
| 425 | -10x | +721 | +4x |
- varlabels = varlabels,+ fit_glm, |
| 426 | -10x | +722 | +4x |
- split_label = "Covariate:",+ conf_level = conf_level, |
| 427 | -10x | +723 | +4x |
- nested = FALSE,+ at = `if`(is_intervar1_numeric, at, NULL) |
| 428 | -10x | +|||
| 724 | +
- child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ ) |
|||
| 429 | -10x | +|||
| 725 | +
- section_div = tail(.section_div, 1)+ |
|||
| 430 | +726 |
- )+ # Now just combine everything in one data frame. |
||
| 431 | -10x | +727 | +4x |
- if (multivar || control$interaction || !"arm" %in% names(variables)) {
+ col_names <- c( |
| 432 | -8x | +728 | +4x |
- lyt <- lyt %>%+ "variable", |
| 433 | -8x | +729 | +4x |
- summarize_row_groups(+ "variable_label", |
| 434 | -8x | +730 | +4x |
- cfun = a_coxreg,+ "term", |
| 435 | -8x | +731 | +4x |
- na_str = na_str,+ "term_label", |
| 436 | -8x | +732 | +4x |
- extra_args = list(+ "interaction", |
| 437 | -8x | +733 | +4x |
- variables = variables, at = at, control = control, multivar = multivar,+ "interaction_label", |
| 438 | -8x | -
- var_main = if (multivar) multivar else control$interaction- |
- ||
| 439 | -- |
- )- |
- ||
| 440 | -- |
- )- |
- ||
| 441 | -- |
- } else {
- |
- ||
| 442 | -! | +734 | +4x |
- if (!is.null(varlabels)) names(varlabels) <- variables$covariates+ "reference", |
| 443 | -2x | +735 | +4x |
- lyt <- lyt %>%+ "reference_label", |
| 444 | -2x | +736 | +4x |
- analyze_colvars(+ "estimate", |
| 445 | -2x | +737 | +4x |
- afun = a_coxreg,+ "std_error", |
| 446 | -2x | +738 | +4x |
- na_str = na_str,+ "df", |
| 447 | -2x | +739 | +4x |
- extra_args = list(+ "pvalue", |
| 448 | -2x | +740 | +4x |
- variables = variables, at = at, control = control, multivar = multivar,+ "odds_ratio", |
| 449 | -2x | +741 | +4x |
- var_main = if (multivar) multivar else control$interaction,+ "lcl", |
| 450 | -2x | +742 | +4x |
- labelstr = if (is.null(varlabels)) "" else varlabels+ "ucl", |
| 451 | -+ | |||
| 743 | +4x |
- )+ "is_variable_summary", |
||
| 452 | -+ | |||
| 744 | +4x |
- )+ "is_term_summary", |
||
| 453 | -+ | |||
| 745 | +4x |
- }+ "is_reference_summary" |
||
| 454 | +746 |
-
+ ) |
||
| 455 | -2x | +747 | +4x |
- if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm+ df <- rbind( |
| 456 | -10x | +748 | +4x |
- if (multivar || control$interaction) { # covariate level effects
+ inter_stats_one[, col_names], |
| 457 | -8x | +749 | +4x |
- lyt <- lyt %>%+ inter_stats_two[, col_names], |
| 458 | -8x | +750 | +4x |
- analyze_colvars(+ inter_term_stats[, col_names] |
| 459 | -8x | +|||
| 751 | +
- afun = a_coxreg,+ ) |
|||
| 460 | -8x | +752 | +4x |
- na_str = na_str,+ if (length(normal_terms) > 0) {
|
| 461 | -8x | +753 | +4x |
- extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""),+ df <- rbind( |
| 462 | -8x | +754 | +4x |
- indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L+ normal_stats[, col_names], |
| 463 | -+ | |||
| 755 | +4x |
- )+ df |
||
| 464 | +756 |
- }+ ) |
||
| 465 | +757 |
} |
||
| 466 | -+ | |||
| 758 | +4x |
-
+ df$ci <- combine_vectors(df$lcl, df$ucl) |
||
| 467 | -10x | +759 | +4x |
- lyt+ df |
| 468 | +760 |
}@@ -48661,14 +50217,14 @@ tern coverage - 90.46% |
| 1 |
- #' Custom Split Functions+ #' Cox Proportional Hazards Regression |
||
| 5 |
- #' Collection of useful functions that are expanding on the core list of functions+ #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis. |
||
| 6 |
- #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()]+ #' |
||
| 7 |
- #' for more information on how to make a custom split function. All these functions+ #' @inheritParams argument_convention |
||
| 8 |
- #' work with [split_rows_by()] argument `split_fun` to modify the way the split+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_coxreg")`
|
||
| 9 |
- #' happens. For other split functions, consider consulting [`rtables::split_funcs`].+ #' to see available statistics for this function. |
||
| 11 |
- #' @seealso [rtables::make_split_fun()]+ #' @details Cox models are the most commonly used methods to estimate the magnitude of |
||
| 12 |
- #'+ #' the effect in survival analysis. It assumes proportional hazards: the ratio |
||
| 13 |
- #' @name utils_split_funs+ #' of the hazards between groups (e.g., two arms) is constant over time. |
||
| 14 |
- NULL+ #' This ratio is referred to as the "hazard ratio" (HR) and is one of the |
||
| 15 |
-
+ #' most commonly reported metrics to describe the effect size in survival |
||
| 16 |
- #' @describeIn utils_split_funs split function to place reference group facet at a specific position+ #' analysis (NEST Team, 2020). |
||
| 17 |
- #' during post-processing stage.+ #' |
||
| 18 |
- #'+ #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant |
||
| 19 |
- #' @param position (`string` or `integer`)\cr should it be `"first"` or `"last"` or in a specific position?+ #' helper functions, and [tidy_coxreg] for custom tidy methods. |
||
| 21 |
- #' @return+ #' @examples |
||
| 22 |
- #' * `ref_group_position` returns an utility function that puts the reference group+ #' library(survival) |
||
| 23 |
- #' as first, last or at a certain position and needs to be assigned to `split_fun`.+ #' |
||
| 24 |
- #'+ #' # Testing dataset [survival::bladder]. |
||
| 25 |
- #' @examples+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 26 |
- #' library(dplyr)+ #' dta_bladder <- with( |
||
| 27 |
- #'+ #' data = bladder[bladder$enum < 5, ], |
||
| 28 |
- #' dat <- data.frame(+ #' tibble::tibble( |
||
| 29 |
- #' x = factor(letters[1:5], levels = letters[5:1]),+ #' TIME = stop, |
||
| 30 |
- #' y = 1:5+ #' STATUS = event, |
||
| 31 |
- #' )+ #' ARM = as.factor(rx), |
||
| 32 |
- #'+ #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
|
||
| 33 |
- #' # With rtables layout functions+ #' COVAR2 = factor( |
||
| 34 |
- #' basic_table() %>%+ #' sample(as.factor(enum)), |
||
| 35 |
- #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 36 |
- #' analyze("y") %>%
+ #' ) %>% formatters::with_label("Sex (F/M)")
|
||
| 37 |
- #' build_table(dat)+ #' ) |
||
| 38 |
- #'+ #' ) |
||
| 39 |
- #' # With tern layout funcitons+ #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 40 |
- #' adtte_f <- tern_ex_adtte %>%+ #' dta_bladder$STUDYID <- factor("X")
|
||
| 41 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 42 |
- #' mutate(+ #' u1_variables <- list( |
||
| 43 |
- #' AVAL = day2month(AVAL),+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
||
| 44 |
- #' is_event = CNSR == 0+ #' ) |
||
| 45 |
- #' )+ #' |
||
| 46 |
- #'+ #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
||
| 47 |
- #' basic_table() %>%+ #' |
||
| 48 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
+ #' m1_variables <- list( |
||
| 49 |
- #' add_colcounts() %>%+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
||
| 50 |
- #' surv_time(+ #' ) |
||
| 51 |
- #' vars = "AVAL",+ #' |
||
| 52 |
- #' var_labels = "Survival Time (Months)",+ #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
||
| 53 |
- #' is_event = "is_event",+ #' |
||
| 54 |
- #' ) %>%+ #' @name cox_regression |
||
| 55 |
- #' build_table(df = adtte_f)+ #' @order 1 |
||
| 56 |
- #'+ NULL |
||
| 57 |
- #' basic_table() %>%+ |
||
| 58 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>%+ #' @describeIn cox_regression Statistics function that transforms results tabulated |
||
| 59 |
- #' add_colcounts() %>%+ #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list. |
||
| 60 |
- #' surv_time(+ #' |
||
| 61 |
- #' vars = "AVAL",+ #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg] |
||
| 62 |
- #' var_labels = "Survival Time (Months)",+ #' function with tidying applied via [broom::tidy()]. |
||
| 63 |
- #' is_event = "is_event",+ #' @param .stats (`character`)\cr the name of statistics to be reported among: |
||
| 64 |
- #' ) %>%+ #' * `n`: number of observations (univariate only) |
||
| 65 |
- #' build_table(df = adtte_f)+ #' * `hr`: hazard ratio |
||
| 66 |
- #'+ #' * `ci`: confidence interval |
||
| 67 |
- #' @export+ #' * `pval`: p-value of the treatment effect |
||
| 68 |
- ref_group_position <- function(position = "first") {
+ #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only) |
||
| 69 | -20x | +
- make_split_fun(+ #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model. |
|
| 70 | -20x | +
- post = list(+ #' Defaults to "all". Other options include "var_main" for main effects, `"inter"` for interaction effects, |
|
| 71 | -20x | +
- function(splret, spl, fulldf) {
+ #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is "all" specific |
|
| 72 | -57x | +
- if (!"ref_group_value" %in% methods::slotNames(spl)) {
+ #' variables can be selected by specifying `.var_nms`. |
|
| 73 | -1x | +
- stop("Reference group is undefined.")
+ #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically |
|
| 74 |
- }+ #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired |
||
| 75 |
-
+ #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars` |
||
| 76 | -56x | +
- spl_var <- rtables:::spl_payload(spl)+ #' is `"var_main"` `.var_nms` should be only the variable name. |
|
| 77 | -56x | +
- fulldf[[spl_var]] <- factor(fulldf[[spl_var]])+ #' |
|
| 78 | -56x | +
- init_lvls <- levels(fulldf[[spl_var]])+ #' @return |
|
| 79 |
-
+ #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s). |
||
| 80 | -56x | +
- if (!all(names(splret$values) %in% init_lvls)) {
+ #' |
|
| 81 | -! | +
- stop("This split function does not work with combination facets.")
+ #' @examples |
|
| 82 |
- }+ #' # s_coxreg |
||
| 83 |
-
+ #' |
||
| 84 | -56x | +
- ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl))+ #' # Univariate |
|
| 85 | -56x | +
- pos_choices <- c("first", "last")
+ #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder) |
|
| 86 | -56x | +
- if (checkmate::test_choice(position, pos_choices) && position == "first") {
+ #' df1 <- broom::tidy(univar_model) |
|
| 87 | -41x | +
- pos <- 0+ #' |
|
| 88 | -15x | +
- } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
+ #' s_coxreg(model_df = df1, .stats = "hr") |
|
| 89 | -12x | +
- pos <- length(init_lvls)+ #' |
|
| 90 | -3x | +
- } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
+ #' # Univariate with interactions |
|
| 91 | -3x | +
- pos <- position - 1+ #' univar_model_inter <- fit_coxreg_univar( |
|
| 92 |
- } else {
+ #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder |
||
| 93 | -! | +
- stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
+ #' ) |
|
| 94 |
- }+ #' df1_inter <- broom::tidy(univar_model_inter) |
||
| 95 |
-
+ #' |
||
| 96 | -56x | +
- reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos)+ #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1") |
|
| 97 | -56x | +
- ord <- match(reord_lvls, names(splret$values))+ #' |
|
| 98 |
-
+ #' # Univariate without treatment arm - only "COVAR2" covariate effects |
||
| 99 | -56x | +
- make_split_result(+ #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder) |
|
| 100 | -56x | +
- splret$values[ord],+ #' df1_covs <- broom::tidy(univar_covs_model) |
|
| 101 | -56x | +
- splret$datasplit[ord],+ #' |
|
| 102 | -56x | +
- splret$labels[ord]+ #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
|
|
| 103 |
- )+ #' |
||
| 104 |
- }+ #' # Multivariate. |
||
| 105 |
- )+ #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder) |
||
| 106 |
- )+ #' df2 <- broom::tidy(multivar_model) |
||
| 107 |
- }+ #' |
||
| 108 |
-
+ #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1") |
||
| 109 |
- #' @describeIn utils_split_funs split function to change level order based on a `integer`+ #' s_coxreg( |
||
| 110 |
- #' vector or a `character` vector that represent the split variable's factor levels.+ #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl", |
||
| 111 |
- #'+ #' .var_nms = c("COVAR1", "A Covariate Label")
|
||
| 112 |
- #' @param order (`character` or `integer`)\cr vector of ordering indexes for the split facets.+ #' ) |
||
| 114 |
- #' @return+ #' # Multivariate without treatment arm - only "COVAR1" main effect |
||
| 115 |
- #' * `level_order` returns an utility function that changes the original levels' order,+ #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder) |
||
| 116 |
- #' depending on input `order` and split levels.+ #' df2_covs <- broom::tidy(multivar_covs_model) |
||
| 118 |
- #' @examples+ #' s_coxreg(model_df = df2_covs, .stats = "hr") |
||
| 119 |
- #' # level_order --------+ #' |
||
| 120 |
- #' # Even if default would bring ref_group first, the original order puts it last+ #' @export |
||
| 121 |
- #' basic_table() %>%+ s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
|
||
| 122 | -+ | 194x |
- #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
+ assert_df_with_variables(model_df, list(term = "term", stat = .stats)) |
| 123 | -+ | 194x |
- #' analyze("Sepal.Length") %>%
+ checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
|
| 124 | -+ | 194x |
- #' build_table(iris)+ model_df$term <- as.character(model_df$term) |
| 125 | -+ | 194x |
- #'+ .var_nms <- .var_nms[!is.na(.var_nms)] |
| 126 |
- #' # character vector+ |
||
| 127 | -+ | 192x |
- #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)])+ if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ] |
| 128 | -+ | 39x |
- #' basic_table() %>%+ if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1) |
| 129 |
- #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
+
|
||
| 130 |
- #' analyze("Sepal.Length") %>%
+ # We need a list with names corresponding to the stats to display of equal length to the list of stats. |
||
| 131 | -+ | 194x |
- #' build_table(iris)+ y <- split(model_df, f = model_df$term, drop = FALSE) |
| 132 | -+ | 194x |
- #'+ y <- stats::setNames(y, nm = rep(.stats, length(y))) |
| 133 |
- #' @export+ |
||
| 134 | -+ | 194x |
- level_order <- function(order) {
+ if (.which_vars == "var_main") {
|
| 135 | -2x | +84x |
- make_split_fun(+ y <- lapply(y, function(x) x[1, ]) # only main effect |
| 136 | -2x | +110x |
- post = list(+ } else if (.which_vars %in% c("inter", "multi_lvl")) {
|
| 137 | -2x | +80x |
- function(splret, spl, fulldf) {
+ y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect |
| 138 | -4x | +
- if (checkmate::test_integerish(order)) {
+ } |
|
| 139 | -1x | +
- checkmate::assert_integerish(order, lower = 1, upper = length(splret$values))+ |
|
| 140 | -1x | +194x |
- ord <- order+ lapply( |
| 141 | -+ | 194x |
- } else {
+ X = y, |
| 142 | -3x | +194x |
- checkmate::assert_character(order, len = length(splret$values))+ FUN = function(x) {
|
| 143 | -3x | +198x |
- checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE)+ z <- as.list(x[[.stats]]) |
| 144 | -3x | +198x |
- ord <- match(order, names(splret$values))+ stats::setNames(z, nm = x$term_label) |
| 145 |
- }+ } |
||
| 146 | -4x | +
- make_split_result(+ ) |
|
| 147 | -4x | +
- splret$values[ord],+ } |
|
| 148 | -4x | +
- splret$datasplit[ord],+ |
|
| 149 | -4x | +
- splret$labels[ord]+ #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()] |
|
| 150 |
- )+ #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`. |
||
| 151 |
- }+ #' |
||
| 152 |
- )+ #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`. |
||
| 153 |
- )+ #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`. |
||
| 154 |
- }+ #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`. |
| 1 | +155 |
- #' Convert List of Groups to Data Frame+ #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to |
||
| 2 | +156 |
- #'+ #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching). |
||
| 3 | +157 |
- #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()].+ #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed |
||
| 4 | +158 |
- #'+ #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing |
||
| 5 | +159 |
- #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the+ #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding |
||
| 6 | +160 |
- #' levels that belong to it in the character vectors that are elements of the list.+ #' effect estimates will be tabulated later. |
||
| 7 | +161 |
#' |
||
| 8 | +162 |
- #' @return [tibble::tibble()] in the required format.+ #' @return |
||
| 9 | +163 | ++ |
+ #' * `a_coxreg()` returns formatted [rtables::CellValue()].+ |
+ |
| 164 |
#' |
|||
| 10 | +165 |
#' @examples |
||
| 11 | +166 |
- #' grade_groups <- list(+ #' a_coxreg( |
||
| 12 | +167 |
- #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
+ #' df = dta_bladder, |
||
| 13 | +168 |
- #' "Grade 3-4 (%)" = c("3", "4"),
+ #' labelstr = "Label 1", |
||
| 14 | +169 |
- #' "Grade 5 (%)" = "5"+ #' variables = u1_variables, |
||
| 15 | +170 |
- #' )+ #' .spl_context = list(value = "COVAR1"), |
||
| 16 | +171 |
- #' groups_list_to_df(grade_groups)+ #' .stats = "n", |
||
| 17 | +172 | ++ |
+ #' .formats = "xx"+ |
+ |
| 173 | ++ |
+ #' )+ |
+ ||
| 174 |
#' |
|||
| 18 | +175 |
- #' @export+ #' a_coxreg( |
||
| 19 | +176 |
- groups_list_to_df <- function(groups_list) {
+ #' df = dta_bladder, |
||
| 20 | -5x | +|||
| 177 | +
- checkmate::assert_list(groups_list, names = "named")+ #' labelstr = "", |
|||
| 21 | -5x | +|||
| 178 | +
- lapply(groups_list, checkmate::assert_character)+ #' variables = u1_variables, |
|||
| 22 | -5x | +|||
| 179 | +
- tibble::tibble(+ #' .spl_context = list(value = "COVAR2"), |
|||
| 23 | -5x | +|||
| 180 | +
- valname = make_names(names(groups_list)),+ #' .stats = "pval", |
|||
| 24 | -5x | +|||
| 181 | +
- label = names(groups_list),+ #' .formats = "xx.xxxx" |
|||
| 25 | -5x | +|||
| 182 | +
- levelcombo = unname(groups_list),+ #' ) |
|||
| 26 | -5x | +|||
| 183 | +
- exargs = replicate(length(groups_list), list())+ #' |
|||
| 27 | +184 |
- )+ #' @export |
||
| 28 | +185 |
- }+ a_coxreg <- function(df, |
||
| 29 | +186 |
-
+ labelstr, |
||
| 30 | +187 |
- #' Reference and Treatment Group Combination+ eff = FALSE, |
||
| 31 | +188 |
- #'+ var_main = FALSE, |
||
| 32 | +189 |
- #' @description `r lifecycle::badge("stable")`
+ multivar = FALSE, |
||
| 33 | +190 |
- #'+ variables, |
||
| 34 | +191 |
- #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of+ at = list(), |
||
| 35 | +192 |
- #' columns in the `rtables` framework and teal modules.+ control = control_coxreg(), |
||
| 36 | +193 |
- #'+ .spl_context, |
||
| 37 | +194 |
- #' @param fct (`factor`)\cr the variable with levels which needs to be grouped.+ .stats, |
||
| 38 | +195 |
- #' @param ref (`string`)\cr the reference level(s).+ .formats, |
||
| 39 | +196 |
- #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`.+ .indent_mods = NULL, |
||
| 40 | +197 |
- #'+ na_level = lifecycle::deprecated(), |
||
| 41 | +198 |
- #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment).+ na_str = "", |
||
| 42 | +199 |
- #'+ cache_env = NULL) {
+ |
+ ||
| 200 | +191x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+ ||
| 201 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "a_coxreg(na_level)", "a_coxreg(na_str)")
+ |
+ ||
| 202 | +! | +
+ na_str <- na_level |
||
| 43 | +203 |
- #' @examples+ } |
||
| 44 | +204 |
- #' groups <- combine_groups(+ + |
+ ||
| 205 | +191x | +
+ cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm+ |
+ ||
| 206 | +191x | +
+ cov <- tail(.spl_context$value, 1) # current variable/covariate+ |
+ ||
| 207 | +191x | +
+ var_lbl <- formatters::var_labels(df)[cov] # check for df labels+ |
+ ||
| 208 | +191x | +
+ if (length(labelstr) > 1) {
+ |
+ ||
| 209 | +! | +
+ labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none+ |
+ ||
| 210 | +191x | +
+ } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
+ |
+ ||
| 211 | +62x | +
+ labelstr <- var_lbl |
||
| 45 | +212 |
- #' fct = DM$ARM,+ }+ |
+ ||
| 213 | +191x | +
+ if (eff || multivar || cov_no_arm) {
+ |
+ ||
| 214 | +82x | +
+ control$interaction <- FALSE |
||
| 46 | +215 |
- #' ref = c("B: Placebo")
+ } else {
+ |
+ ||
| 216 | +109x | +
+ variables$covariates <- cov+ |
+ ||
| 217 | +40x | +
+ if (var_main) control$interaction <- TRUE |
||
| 47 | +218 |
- #' )+ } |
||
| 48 | +219 |
- #'+ + |
+ ||
| 220 | +191x | +
+ if (is.null(cache_env[[cov]])) {
+ |
+ ||
| 221 | +30x | +
+ if (!multivar) {
+ |
+ ||
| 222 | +23x | +
+ model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy() |
||
| 49 | +223 |
- #' basic_table() %>%+ } else {
+ |
+ ||
| 224 | +7x | +
+ model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy() |
||
| 50 | +225 |
- #' split_cols_by_groups("ARM", groups) %>%
+ }+ |
+ ||
| 226 | +30x | +
+ cache_env[[cov]] <- model |
||
| 51 | +227 |
- #' add_colcounts() %>%+ } else {
+ |
+ ||
| 228 | +161x | +
+ model <- cache_env[[cov]] |
||
| 52 | +229 |
- #' analyze_vars("AGE") %>%
+ }+ |
+ ||
| 230 | +109x | +
+ if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_ |
||
| 53 | +231 |
- #' build_table(DM)+ + |
+ ||
| 232 | +191x | +
+ if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
+ |
+ ||
| 233 | +15x | +
+ multivar <- TRUE+ |
+ ||
| 234 | +3x | +
+ if (!cov_no_arm) var_main <- TRUE |
||
| 54 | +235 |
- #'+ } |
||
| 55 | +236 |
- #' @export+ + |
+ ||
| 237 | +191x | +
+ vars_coxreg <- list(which_vars = "all", var_nms = NULL)+ |
+ ||
| 238 | +191x | +
+ if (eff) {
+ |
+ ||
| 239 | +40x | +
+ if (multivar && !var_main) { # multivar treatment level
+ |
+ ||
| 240 | +6x | +
+ var_lbl_arm <- formatters::var_labels(df)[[variables$arm]]+ |
+ ||
| 241 | +6x | +
+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
|
||
| 56 | +242 |
- combine_groups <- function(fct,+ } else { # treatment effect
+ |
+ ||
| 243 | +34x | +
+ vars_coxreg["var_nms"] <- variables$arm+ |
+ ||
| 244 | +6x | +
+ if (var_main) vars_coxreg["which_vars"] <- "var_main" |
||
| 57 | +245 |
- ref = NULL,+ } |
||
| 58 | +246 |
- collapse = "/") {
+ } else {
|
||
| 59 | -10x | +247 | +151x |
- checkmate::assert_string(collapse)+ if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
|
| 60 | -10x | +248 | +118x |
- checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE)+ vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
|
| 61 | -10x | +249 | +33x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ } else if (multivar) { # multivar covariate level
+ |
+
| 250 | +33x | +
+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
+ |
+ ||
| 251 | +6x | +
+ if (var_main) model[cov, .stats] <- NA_real_ |
||
| 62 | +252 |
-
+ } |
||
| 63 | -10x | +253 | +40x |
- fct <- as_factor_keep_attributes(fct)+ if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect |
| 64 | +254 |
-
+ } |
||
| 65 | -10x | +255 | +191x |
- group_levels <- levels(fct)+ var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]] |
| 66 | -10x | +256 | +191x |
- if (is.null(ref)) {
+ var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
|
| 67 | +257 | +21x | +
+ paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels+ |
+ |
| 258 | +191x | +
+ } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) ||+ |
+ ||
| 259 | +191x | +
+ (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
+ |
+ ||
| 260 | +47x | +
+ labelstr # other main effect labels+ |
+ ||
| 261 | +191x | +
+ } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
+ |
+ ||
| 262 | 6x |
- ref <- group_levels[1]+ "All" # multivar numeric covariate |
||
| 68 | +263 |
} else {
|
||
| 69 | -4x | +264 | +117x |
- checkmate::assert_subset(ref, group_levels)+ names(var_vals) |
| 70 | +265 |
} |
||
| 71 | -+ | |||
| 266 | +191x |
-
+ in_rows( |
||
| 72 | -10x | +267 | +191x |
- groups <- list(+ .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods, |
| 73 | -10x | +268 | +191x |
- ref = group_levels[group_levels %in% ref],+ .formats = stats::setNames(rep(.formats, length(var_names)), var_names), |
| 74 | -10x | +269 | +191x |
- trt = group_levels[!group_levels %in% ref]+ .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names) |
| 75 | +270 |
) |
||
| 76 | -10x | -
- stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse))- |
- ||
| 77 | +271 |
} |
||
| 78 | +272 | |||
| 79 | +273 |
- #' Split Columns by Groups of Levels+ #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table |
||
| 80 | +274 |
- #'+ #' layout. This function is a wrapper for several `rtables` layouting functions. This function |
||
| 81 | +275 |
- #' @description `r lifecycle::badge("stable")`
+ #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()]. |
||
| 82 | +276 |
#' |
||
| 83 | +277 |
- #' @inheritParams argument_convention+ #' @inheritParams fit_coxreg_univar |
||
| 84 | +278 |
- #' @inheritParams groups_list_to_df+ #' @param multivar (`flag`)\cr Defaults to `FALSE`. If `TRUE` multivariate Cox regression will run, otherwise |
||
| 85 | +279 |
- #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to+ #' univariate Cox regression will run. |
||
| 86 | +280 |
- #' control formats (`format`), add a joint column for all groups (`incl_all`).+ #' @param common_var (`character`)\cr the name of a factor variable in the dataset which takes the same value |
||
| 87 | +281 |
- #'+ #' for all rows. This should be created during pre-processing if no such variable currently exists. |
||
| 88 | +282 |
- #' @return A layout object suitable for passing to further layouting functions. Adding+ #' @param .section_div (`character`)\cr string which should be repeated as a section divider between sections. |
||
| 89 | +283 |
- #' this function to an `rtable` layout will add a column split including the given+ #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between |
||
| 90 | +284 |
- #' groups to the table layout.+ #' treatment and covariate sections and the second between different covariates. |
||
| 91 | +285 |
#' |
||
| 92 | +286 | ++ |
+ #' @return+ |
+ |
| 287 | ++ |
+ #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions,+ |
+ ||
| 288 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table+ |
+ ||
| 289 |
- #' @seealso [rtables::split_cols_by()]+ #' containing the chosen statistics to the table layout. |
|||
| 93 | +290 |
#' |
||
| 94 | +291 |
- #' @examples+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`, |
||
| 95 | +292 |
- #' # 1 - Basic use+ #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate |
||
| 96 | +293 |
- #'+ #' Cox regression models, respectively. |
||
| 97 | +294 |
- #' # Without group combination `split_cols_by_groups` is+ #' |
||
| 98 | +295 |
- #' # equivalent to [rtables::split_cols_by()].+ #' @examples |
||
| 99 | +296 |
- #' basic_table() %>%+ #' # summarize_coxreg |
||
| 100 | +297 |
- #' split_cols_by_groups("ARM") %>%
+ #' |
||
| 101 | +298 |
- #' add_colcounts() %>%+ #' result_univar <- basic_table() %>% |
||
| 102 | +299 |
- #' analyze("AGE") %>%
+ #' summarize_coxreg(variables = u1_variables) %>% |
||
| 103 | +300 |
- #' build_table(DM)+ #' build_table(dta_bladder) |
||
| 104 | +301 |
- #'+ #' result_univar |
||
| 105 | +302 |
- #' # Add a reference column.+ #' |
||
| 106 | +303 |
- #' basic_table() %>%+ #' result_univar_covs <- basic_table() %>% |
||
| 107 | +304 |
- #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
+ #' summarize_coxreg( |
||
| 108 | +305 |
- #' add_colcounts() %>%+ #' variables = u2_variables, |
||
| 109 | +306 |
- #' analyze(+ #' ) %>% |
||
| 110 | +307 |
- #' "AGE",+ #' build_table(dta_bladder) |
||
| 111 | +308 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ #' result_univar_covs |
||
| 112 | +309 |
- #' if (.in_ref_col) {
+ #' |
||
| 113 | +310 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ #' result_multivar <- basic_table() %>% |
||
| 114 | +311 |
- #' } else {
+ #' summarize_coxreg( |
||
| 115 | +312 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ #' variables = m1_variables, |
||
| 116 | +313 |
- #' }+ #' multivar = TRUE, |
||
| 117 | +314 |
- #' }+ #' ) %>% |
||
| 118 | +315 |
- #' ) %>%+ #' build_table(dta_bladder) |
||
| 119 | +316 |
- #' build_table(DM)+ #' result_multivar |
||
| 120 | +317 |
#' |
||
| 121 | +318 |
- #' # 2 - Adding group specification+ #' result_multivar_covs <- basic_table() %>% |
||
| 122 | +319 |
- #'+ #' summarize_coxreg( |
||
| 123 | +320 |
- #' # Manual preparation of the groups.+ #' variables = m2_variables, |
||
| 124 | +321 |
- #' groups <- list(+ #' multivar = TRUE, |
||
| 125 | +322 |
- #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
+ #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
|
||
| 126 | +323 |
- #' "Arms A+C" = c("A: Drug X", "C: Combination")
+ #' ) %>% |
||
| 127 | +324 |
- #' )+ #' build_table(dta_bladder) |
||
| 128 | +325 |
- #'+ #' result_multivar_covs |
||
| 129 | +326 |
- #' # Use of split_cols_by_groups without reference column.+ #' |
||
| 130 | +327 |
- #' basic_table() %>%+ #' @export |
||
| 131 | +328 |
- #' split_cols_by_groups("ARM", groups) %>%
+ #' @order 2 |
||
| 132 | +329 |
- #' add_colcounts() %>%+ summarize_coxreg <- function(lyt, |
||
| 133 | +330 |
- #' analyze("AGE") %>%
+ variables, |
||
| 134 | +331 |
- #' build_table(DM)+ control = control_coxreg(), |
||
| 135 | +332 |
- #'+ at = list(), |
||
| 136 | +333 |
- #' # Including differentiated output in the reference column.+ multivar = FALSE, |
||
| 137 | +334 |
- #' basic_table() %>%+ common_var = "STUDYID", |
||
| 138 | +335 |
- #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
+ .stats = c("n", "hr", "ci", "pval", "pval_inter"),
|
||
| 139 | +336 |
- #' analyze(+ .formats = c( |
||
| 140 | +337 |
- #' "AGE",+ n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)", |
||
| 141 | +338 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)" |
||
| 142 | +339 |
- #' if (.in_ref_col) {
+ ), |
||
| 143 | +340 |
- #' in_rows("Diff. of Averages" = rcell(NULL))
+ varlabels = NULL, |
||
| 144 | +341 |
- #' } else {
+ .indent_mods = NULL, |
||
| 145 | +342 |
- #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ na_level = lifecycle::deprecated(), |
||
| 146 | +343 |
- #' }+ na_str = "", |
||
| 147 | +344 |
- #' }+ .section_div = NA_character_) {
|
||
| 148 | -+ | |||
| 345 | +11x |
- #' ) %>%+ if (lifecycle::is_present(na_level)) {
|
||
| 149 | -+ | |||
| 346 | +! |
- #' build_table(DM)+ lifecycle::deprecate_warn("0.9.1", "summarize_coxreg(na_level)", "summarize_coxreg(na_str)")
|
||
| 150 | -+ | |||
| 347 | +! |
- #'+ na_str <- na_level |
||
| 151 | +348 |
- #' # 3 - Binary list dividing factor levels into reference and treatment+ } |
||
| 152 | +349 |
- #'+ |
||
| 153 | -+ | |||
| 350 | +11x |
- #' # `combine_groups` defines reference and treatment.+ if (multivar && control$interaction) {
|
||
| 154 | -+ | |||
| 351 | +1x |
- #' groups <- combine_groups(+ warning(paste( |
||
| 155 | -+ | |||
| 352 | +1x |
- #' fct = DM$ARM,+ "Interactions are not available for multivariate cox regression using summarize_coxreg.", |
||
| 156 | -+ | |||
| 353 | +1x |
- #' ref = c("A: Drug X", "B: Placebo")
+ "The model will be calculated without interaction effects." |
||
| 157 | +354 |
- #' )+ )) |
||
| 158 | +355 |
- #' groups+ } |
||
| 159 | -+ | |||
| 356 | +11x |
- #'+ if (control$interaction && !"arm" %in% names(variables)) {
|
||
| 160 | -+ | |||
| 357 | +1x |
- #' # Use group definition without reference column.+ stop("To include interactions please specify 'arm' in variables.")
|
||
| 161 | +358 |
- #' basic_table() %>%+ } |
||
| 162 | +359 |
- #' split_cols_by_groups("ARM", groups_list = groups) %>%
+
|
||
| 163 | -+ | |||
| 360 | +10x |
- #' add_colcounts() %>%+ .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
|
||
| 164 | -+ | |||
| 361 | +4x |
- #' analyze("AGE") %>%
+ intersect(c("hr", "ci", "pval"), .stats)
|
||
| 165 | -+ | |||
| 362 | +10x |
- #' build_table(DM)+ } else if (control$interaction) {
|
||
| 166 | -+ | |||
| 363 | +4x |
- #'+ intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
|
||
| 167 | +364 |
- #' # Use group definition with reference column (first item of groups).+ } else {
|
||
| 168 | -+ | |||
| 365 | +2x |
- #' basic_table() %>%+ intersect(c("n", "hr", "ci", "pval"), .stats)
|
||
| 169 | +366 |
- #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
+ } |
||
| 170 | -+ | |||
| 367 | +10x |
- #' add_colcounts() %>%+ stat_labels <- c( |
||
| 171 | -+ | |||
| 368 | +10x |
- #' analyze(+ n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"), |
||
| 172 | -+ | |||
| 369 | +10x |
- #' "AGE",+ pval = "p-value", pval_inter = "Interaction p-value" |
||
| 173 | +370 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ ) |
||
| 174 | -+ | |||
| 371 | +10x |
- #' if (.in_ref_col) {
+ stat_labels <- stat_labels[names(stat_labels) %in% .stats] |
||
| 175 | -+ | |||
| 372 | +10x |
- #' in_rows("Diff Mean" = rcell(NULL))
+ .formats <- .formats[names(.formats) %in% .stats] |
||
| 176 | -+ | |||
| 373 | +10x |
- #' } else {
+ env <- new.env() # create caching environment |
||
| 177 | +374 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+
|
||
| 178 | -+ | |||
| 375 | +10x |
- #' }+ lyt <- lyt %>% |
||
| 179 | -+ | |||
| 376 | +10x |
- #' }+ split_cols_by_multivar( |
||
| 180 | -+ | |||
| 377 | +10x |
- #' ) %>%+ vars = rep(common_var, length(.stats)), |
||
| 181 | -+ | |||
| 378 | +10x |
- #' build_table(DM)+ varlabels = stat_labels, |
||
| 182 | -+ | |||
| 379 | +10x |
- #'+ extra_args = list( |
||
| 183 | -+ | |||
| 380 | +10x |
- #' @export+ .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)), |
||
| 184 | -+ | |||
| 381 | +10x |
- split_cols_by_groups <- function(lyt,+ cache_env = replicate(length(.stats), list(env)) |
||
| 185 | +382 |
- var,+ ) |
||
| 186 | +383 |
- groups_list = NULL,+ ) |
||
| 187 | +384 |
- ref_group = NULL,+ |
||
| 188 | -+ | |||
| 385 | +10x |
- ...) {
+ if ("arm" %in% names(variables)) { # treatment effect
|
||
| 189 | -6x | +386 | +8x |
- if (is.null(groups_list)) {
+ lyt <- lyt %>% |
| 190 | -2x | +387 | +8x |
- split_cols_by(+ split_rows_by( |
| 191 | -2x | +388 | +8x |
- lyt = lyt,+ common_var, |
| 192 | -2x | +389 | +8x |
- var = var,+ split_label = "Treatment:", |
| 193 | -2x | +390 | +8x |
- ref_group = ref_group,+ label_pos = "visible", |
| 194 | -+ | |||
| 391 | +8x |
- ...+ child_labels = "hidden", |
||
| 195 | -+ | |||
| 392 | +8x |
- )+ section_div = head(.section_div, 1) |
||
| 196 | +393 |
- } else {
+ ) |
||
| 197 | -4x | +394 | +8x |
- groups_df <- groups_list_to_df(groups_list)+ if (!multivar) {
|
| 198 | -4x | +395 | +6x |
- if (!is.null(ref_group)) {
+ lyt <- lyt %>% |
| 199 | -3x | -
- ref_group <- groups_df$valname[groups_df$label == ref_group]- |
- ||
| 200 | -+ | 396 | +6x |
- }+ analyze_colvars( |
| 201 | -4x | +397 | +6x |
- split_cols_by(+ afun = a_coxreg, |
| 202 | -4x | +398 | +6x |
- lyt = lyt,+ na_str = na_str, |
| 203 | -4x | +399 | +6x |
- var = var,+ extra_args = list( |
| 204 | -4x | +400 | +6x |
- split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname),+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar, |
| 205 | -4x | +401 | +6x |
- ref_group = ref_group,+ labelstr = "" |
| 206 | +402 |
- ...+ ) |
||
| 207 | +403 |
- )+ ) |
||
| 208 | +404 |
- }+ } else { # treatment level effects
|
||
| 209 | -+ | |||
| 405 | +2x |
- }+ lyt <- lyt %>% |
||
| 210 | -+ | |||
| 406 | +2x |
-
+ summarize_row_groups( |
||
| 211 | -+ | |||
| 407 | +2x |
- #' Combine Counts+ cfun = a_coxreg, |
||
| 212 | -+ | |||
| 408 | +2x |
- #'+ na_str = na_str, |
||
| 213 | -+ | |||
| 409 | +2x |
- #' Simplifies the estimation of column counts, especially when group combination is required.+ extra_args = list( |
||
| 214 | -+ | |||
| 410 | +2x |
- #'+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar |
||
| 215 | +411 |
- #' @inheritParams combine_groups+ ) |
||
| 216 | +412 |
- #' @inheritParams groups_list_to_df+ ) %>% |
||
| 217 | -+ | |||
| 413 | +2x |
- #'+ analyze_colvars( |
||
| 218 | -+ | |||
| 414 | +2x |
- #' @return A `vector` of column counts.+ afun = a_coxreg, |
||
| 219 | -+ | |||
| 415 | +2x |
- #'+ na_str = na_str, |
||
| 220 | -+ | |||
| 416 | +2x |
- #' @seealso [combine_groups()]+ extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "") |
||
| 221 | +417 |
- #'+ ) |
||
| 222 | +418 |
- #' @examples+ } |
||
| 223 | +419 |
- #' ref <- c("A: Drug X", "B: Placebo")
+ } |
||
| 224 | +420 |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ |
||
| 225 | -+ | |||
| 421 | +10x |
- #'+ if ("covariates" %in% names(variables)) { # covariate main effects
|
||
| 226 | -+ | |||
| 422 | +10x |
- #' col_counts <- combine_counts(+ lyt <- lyt %>% |
||
| 227 | -+ | |||
| 423 | +10x |
- #' fct = DM$ARM,+ split_rows_by_multivar( |
||
| 228 | -+ | |||
| 424 | +10x |
- #' groups_list = groups+ vars = variables$covariates, |
||
| 229 | -+ | |||
| 425 | +10x |
- #' )+ varlabels = varlabels, |
||
| 230 | -+ | |||
| 426 | +10x |
- #'+ split_label = "Covariate:", |
||
| 231 | -+ | |||
| 427 | +10x |
- #' basic_table() %>%+ nested = FALSE, |
||
| 232 | -+ | |||
| 428 | +10x |
- #' split_cols_by_groups("ARM", groups) %>%
+ child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden", |
||
| 233 | -+ | |||
| 429 | +10x |
- #' add_colcounts() %>%+ section_div = tail(.section_div, 1) |
||
| 234 | +430 |
- #' analyze_vars("AGE") %>%
+ ) |
||
| 235 | -+ | |||
| 431 | +10x |
- #' build_table(DM, col_counts = col_counts)+ if (multivar || control$interaction || !"arm" %in% names(variables)) {
|
||
| 236 | -+ | |||
| 432 | +8x |
- #'+ lyt <- lyt %>% |
||
| 237 | -+ | |||
| 433 | +8x |
- #' ref <- "A: Drug X"+ summarize_row_groups( |
||
| 238 | -+ | |||
| 434 | +8x |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ cfun = a_coxreg, |
||
| 239 | -+ | |||
| 435 | +8x |
- #' col_counts <- combine_counts(+ na_str = na_str, |
||
| 240 | -+ | |||
| 436 | +8x |
- #' fct = DM$ARM,+ extra_args = list( |
||
| 241 | -+ | |||
| 437 | +8x |
- #' groups_list = groups+ variables = variables, at = at, control = control, multivar = multivar, |
||
| 242 | -+ | |||
| 438 | +8x |
- #' )+ var_main = if (multivar) multivar else control$interaction |
||
| 243 | +439 |
- #'+ ) |
||
| 244 | +440 |
- #' basic_table() %>%+ ) |
||
| 245 | +441 |
- #' split_cols_by_groups("ARM", groups) %>%
+ } else {
|
||
| 246 | -+ | |||
| 442 | +! |
- #' add_colcounts() %>%+ if (!is.null(varlabels)) names(varlabels) <- variables$covariates |
||
| 247 | -+ | |||
| 443 | +2x |
- #' analyze_vars("AGE") %>%
+ lyt <- lyt %>% |
||
| 248 | -+ | |||
| 444 | +2x |
- #' build_table(DM, col_counts = col_counts)+ analyze_colvars( |
||
| 249 | -+ | |||
| 445 | +2x |
- #'+ afun = a_coxreg, |
||
| 250 | -+ | |||
| 446 | +2x |
- #' @export+ na_str = na_str, |
||
| 251 | -+ | |||
| 447 | +2x |
- combine_counts <- function(fct, groups_list = NULL) {
+ extra_args = list( |
||
| 252 | -4x | +448 | +2x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ variables = variables, at = at, control = control, multivar = multivar,+ |
+
| 449 | +2x | +
+ var_main = if (multivar) multivar else control$interaction,+ |
+ ||
| 450 | +2x | +
+ labelstr = if (is.null(varlabels)) "" else varlabels |
||
| 253 | +451 |
-
+ ) |
||
| 254 | -4x | +|||
| 452 | +
- fct <- as_factor_keep_attributes(fct)+ ) |
|||
| 255 | +453 | ++ |
+ }+ |
+ |
| 454 | ||||
| 256 | -4x | +455 | +2x |
- if (is.null(groups_list)) {
+ if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm |
| 257 | -1x | +456 | +10x |
- y <- table(fct)+ if (multivar || control$interaction) { # covariate level effects
|
| 258 | -1x | +457 | +8x |
- y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ lyt <- lyt %>% |
| 259 | -+ | |||
| 458 | +8x |
- } else {
+ analyze_colvars( |
||
| 260 | -3x | +459 | +8x |
- y <- vapply(+ afun = a_coxreg, |
| 261 | -3x | +460 | +8x |
- X = groups_list,+ na_str = na_str, |
| 262 | -3x | +461 | +8x |
- FUN = function(x) sum(table(fct)[x]),+ extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""), |
| 263 | -3x | +462 | +8x |
- FUN.VALUE = 1+ indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L |
| 264 | +463 |
- )+ )+ |
+ ||
| 464 | ++ |
+ }+ |
+ ||
| 465 | ++ |
+ } |
||
| 265 | +466 |
- }+ |
||
| 266 | -4x | +467 | +10x |
- y+ lyt |
| 267 | +468 |
}@@ -51620,14 +53499,14 @@ tern coverage - 90.46% |
| 1 |
- #' Occurrence Table Pruning+ #' Convert List of Groups to Data Frame |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()]. |
||
| 5 |
- #' Family of constructor and condition functions to flexibly prune occurrence tables.+ #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the |
||
| 6 |
- #' The condition functions always return whether the row result is higher than the threshold.+ #' levels that belong to it in the character vectors that are elements of the list. |
||
| 7 |
- #' Since they are of class [CombinationFunction()] they can be logically combined with other condition+ #' |
||
| 8 |
- #' functions.+ #' @return [tibble::tibble()] in the required format. |
||
| 10 |
- #' @note Since most table specifications are worded positively, we name our constructor and condition+ #' @examples |
||
| 11 |
- #' functions positively, too. However, note that the result of [keep_rows()] says what+ #' grade_groups <- list( |
||
| 12 |
- #' should be pruned, to conform with the [rtables::prune_table()] interface.+ #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
|
||
| 13 |
- #'+ #' "Grade 3-4 (%)" = c("3", "4"),
|
||
| 14 |
- #' @examples+ #' "Grade 5 (%)" = "5" |
||
| 15 |
- #' \donttest{
+ #' ) |
||
| 16 |
- #' tab <- basic_table() %>%+ #' groups_list_to_df(grade_groups) |
||
| 17 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 18 |
- #' split_rows_by("RACE") %>%
+ #' @export |
||
| 19 |
- #' split_rows_by("STRATA1") %>%
+ groups_list_to_df <- function(groups_list) {
|
||
| 20 | -+ | 5x |
- #' summarize_row_groups() %>%+ checkmate::assert_list(groups_list, names = "named") |
| 21 | -+ | 5x |
- #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
+ lapply(groups_list, checkmate::assert_character) |
| 22 | -+ | 5x |
- #' build_table(DM)+ tibble::tibble( |
| 23 | -+ | 5x |
- #' }+ valname = make_names(names(groups_list)), |
| 24 | -+ | 5x |
- #'+ label = names(groups_list), |
| 25 | -+ | 5x |
- #' @name prune_occurrences+ levelcombo = unname(groups_list), |
| 26 | -+ | 5x |
- NULL+ exargs = replicate(length(groups_list), list()) |
| 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+ #' Reference and Treatment Group Combination |
||
| 31 |
- #' children left.+ #' |
||
| 32 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 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.+ #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of |
||
| 35 |
- #'+ #' columns in the `rtables` framework and teal modules. |
||
| 36 |
- #' @return+ #' |
||
| 37 |
- #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()]+ #' @param fct (`factor`)\cr the variable with levels which needs to be grouped. |
||
| 38 |
- #' to prune an `rtables` table.+ #' @param ref (`string`)\cr the reference level(s). |
||
| 39 |
- #'+ #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`. |
||
| 40 |
- #' @examples+ #' |
||
| 41 |
- #' \donttest{
+ #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment). |
||
| 42 |
- #' # `keep_rows`+ #' |
||
| 43 |
- #' is_non_empty <- !CombinationFunction(all_zero_or_na)+ #' @examples |
||
| 44 |
- #' prune_table(tab, keep_rows(is_non_empty))+ #' groups <- combine_groups( |
||
| 45 |
- #' }+ #' fct = DM$ARM, |
||
| 46 |
- #'+ #' ref = c("B: Placebo")
|
||
| 47 |
- #' @export+ #' ) |
||
| 48 |
- keep_rows <- function(row_condition) {
+ #' |
||
| 49 | -6x | +
- checkmate::assert_function(row_condition)+ #' basic_table() %>% |
|
| 50 | -6x | +
- function(table_tree) {
+ #' split_cols_by_groups("ARM", groups) %>%
|
|
| 51 | -2256x | +
- if (inherits(table_tree, "TableRow")) {
+ #' add_colcounts() %>% |
|
| 52 | -1872x | +
- return(!row_condition(table_tree))+ #' analyze_vars("AGE") %>%
|
|
| 53 |
- }+ #' build_table(DM) |
||
| 54 | -384x | +
- children <- tree_children(table_tree)+ #' |
|
| 55 | -384x | +
- identical(length(children), 0L)+ #' @export |
|
| 56 |
- }+ combine_groups <- function(fct, |
||
| 57 |
- }+ ref = NULL, |
||
| 58 |
-
+ collapse = "/") {
|
||
| 59 | -+ | 10x |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ checkmate::assert_string(collapse) |
| 60 | -+ | 10x |
- #' a condition for the (first) content row in leaf tables. This removes all leaf tables where+ checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE) |
| 61 | -+ | 10x |
- #' the first content row does not fulfill the condition. It does not check individual rows.+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
|
| 62 |
- #' It then proceeds recursively by removing the sub tree if there are no children left.+ |
||
| 63 | -+ | 10x |
- #'+ fct <- as_factor_keep_attributes(fct) |
| 64 |
- #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual+ |
||
| 65 | -+ | 10x |
- #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.+ group_levels <- levels(fct) |
| 66 | -+ | 10x |
- #'+ if (is.null(ref)) {
|
| 67 | -+ | 6x |
- #' @return+ ref <- group_levels[1] |
| 68 |
- #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content+ } else {
|
||
| 69 | -+ | 4x |
- #' row of leaf tables in the table.+ checkmate::assert_subset(ref, group_levels) |
| 70 |
- #'+ } |
||
| 71 |
- #' @examples+ |
||
| 72 | -+ | 10x |
- #' # `keep_content_rows`+ groups <- list( |
| 73 | -+ | 10x |
- #' \donttest{
+ ref = group_levels[group_levels %in% ref], |
| 74 | -+ | 10x |
- #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))+ trt = group_levels[!group_levels %in% ref] |
| 75 |
- #' prune_table(tab, keep_content_rows(more_than_twenty))+ ) |
||
| 76 | -+ | 10x |
- #' }+ stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse)) |
| 77 |
- #'+ } |
||
| 78 |
- #' @export+ |
||
| 79 |
- keep_content_rows <- function(content_row_condition) {
+ #' Split Columns by Groups of Levels |
||
| 80 | -1x | +
- checkmate::assert_function(content_row_condition)+ #' |
|
| 81 | -1x | +
- function(table_tree) {
+ #' @description `r lifecycle::badge("stable")`
|
|
| 82 | -166x | +
- if (is_leaf_table(table_tree)) {
+ #' |
|
| 83 | -24x | +
- content_row <- h_content_first_row(table_tree)+ #' @inheritParams argument_convention |
|
| 84 | -24x | +
- return(!content_row_condition(content_row))+ #' @inheritParams groups_list_to_df |
|
| 85 |
- }+ #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to |
||
| 86 | -142x | +
- if (inherits(table_tree, "DataRow")) {
+ #' control formats (`format`), add a joint column for all groups (`incl_all`). |
|
| 87 | -120x | +
- return(FALSE)+ #' |
|
| 88 |
- }+ #' @return A layout object suitable for passing to further layouting functions. Adding |
||
| 89 | -22x | +
- children <- tree_children(table_tree)+ #' this function to an `rtable` layout will add a column split including the given |
|
| 90 | -22x | +
- identical(length(children), 0L)+ #' groups to the table layout. |
|
| 91 |
- }+ #' |
||
| 92 |
- }+ #' @seealso [rtables::split_cols_by()] |
||
| 93 |
-
+ #' |
||
| 94 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns.+ #' @examples |
||
| 95 |
- #'+ #' # 1 - Basic use |
||
| 96 |
- #' @param atleast (`count` or `proportion`)\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+ #' # Without group combination `split_cols_by_groups` is |
||
| 98 |
- #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices+ #' # equivalent to [rtables::split_cols_by()]. |
||
| 99 |
- #' directly instead.+ #' basic_table() %>% |
||
| 100 |
- #'+ #' split_cols_by_groups("ARM") %>%
|
||
| 101 |
- #' @return+ #' add_colcounts() %>% |
||
| 102 |
- #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column.+ #' analyze("AGE") %>%
|
||
| 103 |
- #'+ #' build_table(DM) |
||
| 104 |
- #' @examples+ #' |
||
| 105 |
- #' \donttest{
+ #' # Add a reference column. |
||
| 106 |
- #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))+ #' basic_table() %>% |
||
| 107 |
- #' prune_table(tab, keep_rows(more_than_one))+ #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
|
||
| 108 |
- #' }+ #' add_colcounts() %>% |
||
| 109 |
- #'+ #' analyze( |
||
| 110 |
- #' @export+ #' "AGE", |
||
| 111 |
- has_count_in_cols <- function(atleast, ...) {
+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 112 | -3x | +
- checkmate::assert_count(atleast)+ #' if (.in_ref_col) {
|
|
| 113 | -3x | +
- CombinationFunction(function(table_row) {
+ #' in_rows("Diff Mean" = rcell(NULL))
|
|
| 114 | -334x | +
- row_counts <- h_row_counts(table_row, ...)+ #' } else {
|
|
| 115 | -334x | +
- total_count <- sum(row_counts)+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
|
| 116 | -334x | +
- total_count >= atleast+ #' } |
|
| 117 |
- })+ #' } |
||
| 118 |
- }+ #' ) %>% |
||
| 119 |
-
+ #' build_table(DM) |
||
| 120 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in+ #' |
||
| 121 |
- #' the specified columns satisfying a threshold.+ #' # 2 - Adding group specification |
||
| 123 |
- #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row.+ #' # Manual preparation of the groups. |
||
| 124 |
- #'+ #' groups <- list( |
||
| 125 |
- #' @return+ #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
|
||
| 126 |
- #' * `has_count_in_any_col()` returns a condition function that compares the counts in the+ #' "Arms A+C" = c("A: Drug X", "C: Combination")
|
||
| 127 |
- #' specified columns with the threshold.+ #' ) |
||
| 129 |
- #' @examples+ #' # Use of split_cols_by_groups without reference column. |
||
| 130 |
- #' \donttest{
+ #' basic_table() %>% |
||
| 131 |
- #' # `has_count_in_any_col`+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 132 |
- #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))+ #' add_colcounts() %>% |
||
| 133 |
- #' prune_table(tab, keep_rows(any_more_than_one))+ #' analyze("AGE") %>%
|
||
| 134 |
- #' }+ #' build_table(DM) |
||
| 136 |
- #' @export+ #' # Including differentiated output in the reference column. |
||
| 137 |
- has_count_in_any_col <- function(atleast, ...) {
+ #' basic_table() %>% |
||
| 138 | -! | +
- checkmate::assert_count(atleast)+ #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
|
|
| 139 | -! | +
- CombinationFunction(function(table_row) {
+ #' analyze( |
|
| 140 | -! | +
- row_counts <- h_row_counts(table_row, ...)+ #' "AGE", |
|
| 141 | -! | +
- any(row_counts >= atleast)+ #' afun = function(x, .ref_group, .in_ref_col) {
|
|
| 142 |
- })+ #' if (.in_ref_col) {
|
||
| 143 |
- }+ #' in_rows("Diff. of Averages" = rcell(NULL))
|
||
| 144 |
-
+ #' } else {
|
||
| 145 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in+ #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 146 |
- #' the specified columns.+ #' } |
||
| 147 |
- #'+ #' } |
||
| 148 |
- #' @return+ #' ) %>% |
||
| 149 |
- #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the+ #' build_table(DM) |
||
| 150 |
- #' specified column, and computes the fraction by dividing by the total column counts.+ #' |
||
| 151 |
- #'+ #' # 3 - Binary list dividing factor levels into reference and treatment |
||
| 152 |
- #' @examples+ #' |
||
| 153 |
- #' \donttest{
+ #' # `combine_groups` defines reference and treatment. |
||
| 154 |
- #' # `has_fraction_in_cols`+ #' groups <- combine_groups( |
||
| 155 |
- #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))+ #' fct = DM$ARM, |
||
| 156 |
- #' prune_table(tab, keep_rows(more_than_five_percent))+ #' ref = c("A: Drug X", "B: Placebo")
|
||
| 157 |
- #' }+ #' ) |
||
| 158 |
- #'+ #' groups |
||
| 159 |
- #' @export+ #' |
||
| 160 |
- has_fraction_in_cols <- function(atleast, ...) {
+ #' # Use group definition without reference column. |
||
| 161 | -1x | +
- assert_proportion_value(atleast, include_boundaries = TRUE)+ #' basic_table() %>% |
|
| 162 | -1x | +
- CombinationFunction(function(table_row) {
+ #' split_cols_by_groups("ARM", groups_list = groups) %>%
|
|
| 163 | -303x | +
- row_counts <- h_row_counts(table_row, ...)+ #' add_colcounts() %>% |
|
| 164 | -303x | +
- total_count <- sum(row_counts)+ #' analyze("AGE") %>%
|
|
| 165 | -303x | +
- col_counts <- h_col_counts(table_row, ...)+ #' build_table(DM) |
|
| 166 | -303x | +
- total_n <- sum(col_counts)+ #' |
|
| 167 | -303x | +
- total_percent <- total_count / total_n+ #' # Use group definition with reference column (first item of groups). |
|
| 168 | -303x | +
- total_percent >= atleast+ #' basic_table() %>% |
|
| 169 |
- })+ #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
|
||
| 170 |
- }+ #' add_colcounts() %>% |
||
| 171 |
-
+ #' analyze( |
||
| 172 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in+ #' "AGE", |
||
| 173 |
- #' the specified columns.+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 174 |
- #'+ #' if (.in_ref_col) {
|
||
| 175 |
- #' @return+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 176 |
- #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions+ #' } else {
|
||
| 177 |
- #' in the specified columns and checks whether any of them fulfill the threshold.+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 178 |
- #'+ #' } |
||
| 179 |
- #' @examples+ #' } |
||
| 180 |
- #' \donttest{
+ #' ) %>% |
||
| 181 |
- #' # `has_fraction_in_any_col`+ #' build_table(DM) |
||
| 182 |
- #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))+ #' |
||
| 183 |
- #' prune_table(tab, keep_rows(more_than_five_percent))+ #' @export |
||
| 184 |
- #' }+ split_cols_by_groups <- function(lyt, |
||
| 185 |
- #'+ var, |
||
| 186 |
- #' @export+ groups_list = NULL, |
||
| 187 |
- has_fraction_in_any_col <- function(atleast, ...) {
+ ref_group = NULL, |
||
| 188 | -! | +
- assert_proportion_value(atleast, include_boundaries = TRUE)+ ...) {
|
|
| 189 | -! | +6x |
- CombinationFunction(function(table_row) {
+ if (is.null(groups_list)) {
|
| 190 | -! | +2x |
- row_fractions <- h_row_fractions(table_row, ...)+ split_cols_by( |
| 191 | -! | +2x |
- any(row_fractions >= atleast)+ lyt = lyt, |
| 192 | -+ | 2x |
- })+ var = var, |
| 193 | -+ | 2x |
- }+ ref_group = ref_group, |
| 194 |
-
+ ... |
||
| 195 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ ) |
||
| 196 |
- #' between the fractions reported in each specified column.+ } else {
|
||
| 197 | -+ | 4x |
- #'+ groups_df <- groups_list_to_df(groups_list) |
| 198 | -+ | 4x |
- #' @return+ if (!is.null(ref_group)) {
|
| 199 | -+ | 3x |
- #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each+ ref_group <- groups_df$valname[groups_df$label == ref_group] |
| 200 |
- #' specified column, and computes the difference of the minimum and maximum.+ } |
||
| 201 | -+ | 4x |
- #'+ split_cols_by( |
| 202 | -+ | 4x |
- #' @examples+ lyt = lyt, |
| 203 | -+ | 4x |
- #' \donttest{
+ var = var, |
| 204 | -+ | 4x |
- #' # `has_fractions_difference`+ split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname), |
| 205 | -+ | 4x |
- #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))+ ref_group = ref_group, |
| 206 |
- #' prune_table(tab, keep_rows(more_than_five_percent_diff))+ ... |
||
| 207 |
- #' }+ ) |
||
| 208 |
- #'+ } |
||
| 209 |
- #' @export+ } |
||
| 210 |
- has_fractions_difference <- function(atleast, ...) {
+
|
||
| 211 | -1x | +
- assert_proportion_value(atleast, include_boundaries = TRUE)+ #' Combine Counts |
|
| 212 | -1x | +
- CombinationFunction(function(table_row) {
+ #' |
|
| 213 | -243x | +
- fractions <- h_row_fractions(table_row, ...)+ #' Simplifies the estimation of column counts, especially when group combination is required. |
|
| 214 | -243x | +
- difference <- diff(range(fractions))+ #' |
|
| 215 | -243x | +
- difference >= atleast+ #' @inheritParams combine_groups |
|
| 216 |
- })+ #' @inheritParams groups_list_to_df |
||
| 217 |
- }+ #' |
||
| 218 |
-
+ #' @return A `vector` of column counts. |
||
| 219 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ #' |
||
| 220 |
- #' between the counts reported in each specified column.+ #' @seealso [combine_groups()] |
||
| 222 |
- #' @return+ #' @examples |
||
| 223 |
- #' * `has_counts_difference()` returns a condition function that extracts the counts of each+ #' ref <- c("A: Drug X", "B: Placebo")
|
||
| 224 |
- #' specified column, and computes the difference of the minimum and maximum.+ #' groups <- combine_groups(fct = DM$ARM, ref = ref) |
||
| 226 |
- #' @examples+ #' col_counts <- combine_counts( |
||
| 227 |
- #' \donttest{
+ #' fct = DM$ARM, |
||
| 228 |
- #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))+ #' groups_list = groups |
||
| 229 |
- #' prune_table(tab, keep_rows(more_than_one_diff))+ #' ) |
||
| 230 |
- #' }+ #' |
||
| 231 |
- #'+ #' basic_table() %>% |
||
| 232 |
- #' @export+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 233 |
- has_counts_difference <- function(atleast, ...) {
+ #' add_colcounts() %>% |
||
| 234 | -1x | +
- checkmate::assert_count(atleast)+ #' analyze_vars("AGE") %>%
|
|
| 235 | -1x | +
- CombinationFunction(function(table_row) {
+ #' build_table(DM, col_counts = col_counts) |
|
| 236 | -27x | +
- counts <- h_row_counts(table_row, ...)+ #' |
|
| 237 | -27x | +
- difference <- diff(range(counts))+ #' ref <- "A: Drug X" |
|
| 238 | -27x | +
- difference >= atleast+ #' groups <- combine_groups(fct = DM$ARM, ref = ref) |
|
| 239 |
- })+ #' col_counts <- combine_counts( |
||
| 240 | + |
+ #' fct = DM$ARM,+ |
+ |
| 241 | ++ |
+ #' groups_list = groups+ |
+ |
| 242 | ++ |
+ #' )+ |
+ |
| 243 | ++ |
+ #'+ |
+ |
| 244 | ++ |
+ #' basic_table() %>%+ |
+ |
| 245 | ++ |
+ #' split_cols_by_groups("ARM", groups) %>%
+ |
+ |
| 246 | ++ |
+ #' add_colcounts() %>%+ |
+ |
| 247 | ++ |
+ #' analyze_vars("AGE") %>%
+ |
+ |
| 248 | ++ |
+ #' build_table(DM, col_counts = col_counts)+ |
+ |
| 249 | ++ |
+ #'+ |
+ |
| 250 | ++ |
+ #' @export+ |
+ |
| 251 | ++ |
+ combine_counts <- function(fct, groups_list = NULL) {
+ |
+ |
| 252 | +4x | +
+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ |
+ |
| 253 | ++ | + + | +|
| 254 | +4x | +
+ fct <- as_factor_keep_attributes(fct)+ |
+ |
| 255 | ++ | + + | +|
| 256 | +4x | +
+ if (is.null(groups_list)) {
+ |
+ |
| 257 | +1x | +
+ y <- table(fct)+ |
+ |
| 258 | +1x | +
+ y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ |
+ |
| 259 | ++ |
+ } else {
+ |
+ |
| 260 | +3x | +
+ y <- vapply(+ |
+ |
| 261 | +3x | +
+ X = groups_list,+ |
+ |
| 262 | +3x | +
+ FUN = function(x) sum(table(fct)[x]),+ |
+ |
| 263 | +3x | +
+ FUN.VALUE = 1+ |
+ |
| 264 | ++ |
+ )+ |
+ |
| 265 | ++ |
+ }+ |
+ |
| 266 | +4x | +
+ y+ |
+ |
| 267 | +
} |
@@ -53306,14 +55374,14 @@
| 1 |
- #' Counting Patients and Events in Columns+ #' Helper Functions for Tabulating Survival Duration by Subgroup |
||
| 5 |
- #' Counting the number of unique patients and the total number of all and specific events+ #' Helper functions that tabulate in a data frame statistics such as median survival |
||
| 6 |
- #' when a column table layout is required.+ #' time and hazard ratio for population subgroups. |
||
| 9 |
- #' @param filters_list (named `list` of `character`)\cr each element in this list describes one+ #' @inheritParams survival_coxph_pairwise |
||
| 10 |
- #' type of event describe by filters, in the same format as [s_count_patients_with_event()].+ #' @inheritParams survival_duration_subgroups |
||
| 11 |
- #' If it has a label, then this will be used for the column title.+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 12 |
- #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such+ #' |
||
| 13 |
- #' that corresponding table cells will stay blank.+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 14 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will+ #' |
||
| 15 |
- #' be used as label.+ #' @examples |
||
| 16 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run+ #' library(dplyr) |
||
| 17 |
- #' `get_stats("summarize_patients_events_in_cols")` to see available statistics for this function, in addition
+ #' library(forcats) |
||
| 18 |
- #' to any added using `filters_list`.+ #' |
||
| 19 |
- #'+ #' adtte <- tern_ex_adtte |
||
| 20 |
- #' @name count_patients_events_in_cols+ #' |
||
| 21 |
- #' @order 1+ #' # Save variable labels before data processing steps. |
||
| 22 |
- NULL+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 23 |
-
+ #' |
||
| 24 |
- #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple+ #' adtte_f <- adtte %>% |
||
| 25 |
- #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`.+ #' filter( |
||
| 26 |
- #'+ #' PARAMCD == "OS", |
||
| 27 |
- #' @return+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 28 |
- #' * `s_count_patients_and_multiple_events()` returns a list with the statistics:+ #' SEX %in% c("M", "F")
|
||
| 29 |
- #' - `unique`: number of unique patients in `df`.+ #' ) %>% |
||
| 30 |
- #' - `all`: number of rows in `df`.+ #' mutate( |
||
| 31 |
- #' - one element with the same name as in `filters_list`: number of rows in `df`,+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 32 |
- #' i.e. events, fulfilling the filter condition.+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 33 |
- #'+ #' SEX = droplevels(SEX), |
||
| 34 |
- #' @keywords internal+ #' is_event = CNSR == 0 |
||
| 35 |
- s_count_patients_and_multiple_events <- function(df, # nolint+ #' ) |
||
| 36 |
- id,+ #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
|
||
| 37 |
- filters_list,+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 38 |
- empty_stats = character(),+ #' |
||
| 39 |
- labelstr = "",+ #' @name h_survival_duration_subgroups |
||
| 40 |
- custom_label = NULL) {
+ NULL |
||
| 41 | -9x | +
- checkmate::assert_list(filters_list, names = "named")+ |
|
| 42 | -9x | +
- checkmate::assert_data_frame(df)+ #' @describeIn h_survival_duration_subgroups helper to prepare a data frame of median survival times by arm. |
|
| 43 | -9x | +
- checkmate::assert_string(id)+ #' |
|
| 44 | -9x | +
- checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
+ #' @return |
|
| 45 | -9x | +
- checkmate::assert_character(empty_stats)+ #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`. |
|
| 46 | -9x | +
- checkmate::assert_string(labelstr)+ #' |
|
| 47 | -9x | +
- checkmate::assert_string(custom_label, null.ok = TRUE)+ #' @examples |
|
| 48 |
-
+ #' # Extract median survival time for one group. |
||
| 49 |
- # Below we want to count each row in `df` once, therefore introducing this helper index column.+ #' h_survtime_df( |
||
| 50 | -9x | +
- df$.row_index <- as.character(seq_len(nrow(df)))+ #' tte = adtte_f$AVAL, |
|
| 51 | -9x | +
- y <- list()+ #' is_event = adtte_f$is_event, |
|
| 52 | -9x | +
- row_label <- if (labelstr != "") {
+ #' arm = adtte_f$ARM |
|
| 53 | -! | +
- labelstr+ #' ) |
|
| 54 | -9x | +
- } else if (!is.null(custom_label)) {
+ #' |
|
| 55 | -2x | +
- custom_label+ #' @export |
|
| 56 |
- } else {
+ h_survtime_df <- function(tte, is_event, arm) {
|
||
| 57 | -7x | +61x |
- "counts"+ checkmate::assert_numeric(tte) |
| 58 | -+ | 60x |
- }+ checkmate::assert_logical(is_event, len = length(tte)) |
| 59 | -9x | +60x |
- y$unique <- formatters::with_label(+ assert_valid_factor(arm, len = length(tte)) |
| 60 | -9x | +
- s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L],+ |
|
| 61 | -9x | +60x |
- row_label+ df_tte <- data.frame( |
| 62 | -+ | 60x |
- )+ tte = tte, |
| 63 | -9x | +60x |
- y$all <- formatters::with_label(+ is_event = is_event, |
| 64 | -9x | +60x |
- nrow(df),+ stringsAsFactors = FALSE |
| 65 | -9x | +
- row_label+ ) |
|
| 66 |
- )+ |
||
| 67 | -9x | +
- events <- Map(+ # Delete NAs |
|
| 68 | -9x | +60x |
- function(filters) {
+ non_missing_rows <- stats::complete.cases(df_tte) |
| 69 | -25x | +60x |
- formatters::with_label(+ df_tte <- df_tte[non_missing_rows, ] |
| 70 | -25x | +60x |
- s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count,+ arm <- arm[non_missing_rows] |
| 71 | -25x | +
- row_label+ |
|
| 72 | -+ | 60x |
- )+ lst_tte <- split(df_tte, arm) |
| 73 | -+ | 60x |
- },+ lst_results <- Map(function(x, arm) {
|
| 74 | -9x | +120x |
- filters = filters_list+ if (nrow(x) > 0) {
|
| 75 | -+ | 116x |
- )+ s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event") |
| 76 | -9x | +116x |
- y_complete <- c(y, events)+ median_est <- unname(as.numeric(s_surv$median)) |
| 77 | -9x | +116x |
- y <- if (length(empty_stats) > 0) {
+ n_events <- sum(x$is_event) |
| 78 | -3x | +
- y_reduced <- y_complete+ } else {
|
|
| 79 | -3x | +4x |
- for (stat in intersect(names(y_complete), empty_stats)) {
+ median_est <- NA |
| 80 | 4x |
- y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]]))+ n_events <- NA |
|
| 82 | -3x | +
- y_reduced+ |
|
| 83 | -+ | 120x |
- } else {
+ data.frame( |
| 84 | -6x | +120x |
- y_complete+ arm = arm, |
| 85 | -+ | 120x |
- }+ n = nrow(x), |
| 86 | -9x | +120x |
- y+ n_events = n_events, |
| 87 | -+ | 120x |
- }+ median = median_est, |
| 88 | -+ | 120x |
-
+ stringsAsFactors = FALSE |
| 89 |
- #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function+ ) |
||
| 90 | -+ | 60x |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ }, lst_tte, names(lst_tte)) |
| 91 |
- #'+ |
||
| 92 | -+ | 60x |
- #' @param col_split (`flag`)\cr whether the columns should be split.+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 93 | -+ | 60x |
- #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe.+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 94 | -+ | 60x |
- #'+ df |
| 95 |
- #' @return+ } |
||
| 96 |
- #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions,+ |
||
| 97 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ #' @describeIn h_survival_duration_subgroups summarizes median survival times by arm and across subgroups |
||
| 98 |
- #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout.+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 99 |
- #'+ #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 100 |
- #' @examples+ #' groupings for `subgroups` variables. |
||
| 101 |
- #' df <- data.frame(+ #' |
||
| 102 |
- #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
+ #' @return |
||
| 103 |
- #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
+ #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`, |
||
| 104 |
- #' AESER = rep("Y", 7),
+ #' `var`, `var_label`, and `row_type`. |
||
| 105 |
- #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
+ #' |
||
| 106 |
- #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
+ #' @examples |
||
| 107 |
- #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
+ #' # Extract median survival time for multiple groups. |
||
| 108 |
- #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
+ #' h_survtime_subgroups_df( |
||
| 109 |
- #' )+ #' variables = list( |
||
| 110 |
- #'+ #' tte = "AVAL", |
||
| 111 |
- #' # `summarize_patients_events_in_cols()`+ #' is_event = "is_event", |
||
| 112 |
- #' basic_table() %>%+ #' arm = "ARM", |
||
| 113 |
- #' summarize_patients_events_in_cols(+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 114 |
- #' filters_list = list(+ #' ), |
||
| 115 |
- #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"),+ #' data = adtte_f |
||
| 116 |
- #' fatal = c(AESDTH = "Y"),+ #' ) |
||
| 117 |
- #' fatal_related = c(AEREL = "Y", AESDTH = "Y")+ #' |
||
| 118 |
- #' ),+ #' # Define groupings for BMRKR2 levels. |
||
| 119 |
- #' custom_label = "%s Total number of patients and events"+ #' h_survtime_subgroups_df( |
||
| 120 |
- #' ) %>%+ #' variables = list( |
||
| 121 |
- #' build_table(df)+ #' tte = "AVAL", |
||
| 122 |
- #'+ #' is_event = "is_event", |
||
| 123 |
- #' @export+ #' arm = "ARM", |
||
| 124 |
- #' @order 2+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 125 |
- summarize_patients_events_in_cols <- function(lyt, # nolint+ #' ), |
||
| 126 |
- id = "USUBJID",+ #' data = adtte_f, |
||
| 127 |
- filters_list = list(),+ #' groups_lists = list( |
||
| 128 |
- empty_stats = character(),+ #' BMRKR2 = list( |
||
| 129 |
- na_str = default_na_str(),+ #' "low" = "LOW", |
||
| 130 |
- ...,+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 131 |
- .stats = c(+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 132 |
- "unique",+ #' ) |
||
| 133 |
- "all",+ #' ) |
||
| 134 |
- names(filters_list)+ #' ) |
||
| 135 |
- ),+ #' |
||
| 136 |
- .labels = c(+ #' @export |
||
| 137 |
- unique = "Patients (All)",+ h_survtime_subgroups_df <- function(variables, |
||
| 138 |
- all = "Events (All)",+ data, |
||
| 139 |
- labels_or_names(filters_list)+ groups_lists = list(), |
||
| 140 |
- ),+ label_all = "All Patients") {
|
||
| 141 | -+ | 12x |
- col_split = TRUE) {
+ checkmate::assert_character(variables$tte) |
| 142 | -2x | +12x |
- extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...)+ checkmate::assert_character(variables$is_event) |
| 143 | -+ | 12x |
-
+ checkmate::assert_character(variables$arm) |
| 144 | -2x | +12x |
- afun_list <- Map(+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 145 | -2x | +
- function(stat) {
+
|
|
| 146 | -7x | +12x |
- make_afun(+ assert_df_with_variables(data, variables) |
| 147 | -7x | +
- s_count_patients_and_multiple_events,+ |
|
| 148 | -7x | +12x |
- .stats = stat,+ checkmate::assert_string(label_all) |
| 149 | -7x | +
- .formats = "xx."+ |
|
| 150 |
- )+ # Add All Patients. |
||
| 151 | -+ | 12x |
- },+ result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]]) |
| 152 | -2x | +12x |
- stat = .stats+ result_all$subgroup <- label_all |
| 153 | -+ | 12x |
- )+ result_all$var <- "ALL" |
| 154 | -2x | +12x |
- if (col_split) {
+ result_all$var_label <- label_all |
| 155 | -2x | +12x |
- lyt <- split_cols_by_multivar(+ result_all$row_type <- "content" |
| 156 | -2x | +
- lyt = lyt,+ |
|
| 157 | -2x | +
- vars = rep(id, length(.stats)),+ # Add Subgroups. |
|
| 158 | -2x | +12x |
- varlabels = .labels[.stats]+ if (is.null(variables$subgroups)) {
|
| 159 | -+ | 3x |
- )+ result_all |
| 160 |
- }+ } else {
|
||
| 161 | -2x | +9x |
- summarize_row_groups(+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 162 | -2x | +9x |
- lyt = lyt,+ l_result <- lapply(l_data, function(grp) {
|
| 163 | -2x | +45x |
- cfun = afun_list,+ result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]]) |
| 164 | -2x | +45x |
- na_str = na_str,+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 165 | -2x | +45x |
- extra_args = extra_args+ cbind(result, result_labels) |
| 166 |
- )+ }) |
||
| 167 | -- |
- }- |
-
| 1 | -- |
- #' Helper Function to create a map dataframe that can be used in `trim_levels_to_map` split function.- |
- ||
| 2 | -+ | 9x |
- #'+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
|
| 3 | -+ | |||
| 168 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ result_subgroups$row_type <- "analysis" |
||
| 4 | -+ | |||
| 169 | +9x |
- #'+ rbind( |
||
| 5 | -+ | |||
| 170 | +9x |
- #' Helper Function to create a map dataframe from the input dataset, which can be used as an argument in the+ result_all, |
||
| 6 | -+ | |||
| 171 | +9x |
- #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.+ result_subgroups |
||
| 7 | +172 |
- #'+ ) |
||
| 8 | +173 |
- #' @inheritParams argument_convention+ } |
||
| 9 | +174 |
- #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of+ } |
||
| 10 | +175 |
- #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or+ |
||
| 11 | +176 |
- #' `abnormal = list(Low = "LOW", High = "HIGH"))`+ #' @describeIn h_survival_duration_subgroups helper to prepare a data frame with estimates of |
||
| 12 | +177 |
- #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`.+ #' treatment hazard ratio. |
||
| 13 | +178 |
#' |
||
| 14 | +179 |
- #' @return A map `data.frame`.+ #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed. |
||
| 15 | +180 |
#' |
||
| 16 | -- |
- #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the- |
- ||
| 17 | +181 |
- #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is+ #' @return |
||
| 18 | +182 |
- #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0+ #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, |
||
| 19 | +183 |
- #' for low direction and at least one observation with high range is not missing for high direction.+ #' `conf_level`, `pval` and `pval_label`. |
||
| 20 | +184 |
#' |
||
| 21 | +185 |
#' @examples |
||
| 22 | -- |
- #' adlb <- df_explicit_na(tern_ex_adlb)- |
- ||
| 23 | -- |
- #'- |
- ||
| 24 | -- |
- #' h_map_for_count_abnormal(- |
- ||
| 25 | -- |
- #' df = adlb,- |
- ||
| 26 | -- |
- #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
- |
- ||
| 27 | -- |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
- |
- ||
| 28 | -- |
- #' method = "default",- |
- ||
| 29 | +186 |
- #' na_str = "<Missing>"+ #' # Extract hazard ratio for one group. |
||
| 30 | +187 |
- #' )+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM) |
||
| 31 | +188 |
#' |
||
| 32 | -- |
- #' df <- data.frame(- |
- ||
| 33 | -- |
- #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
- |
- ||
| 34 | -- |
- #' AVISIT = c(- |
- ||
| 35 | -- |
- #' rep("WEEK 1", 2),
- |
- ||
| 36 | -- |
- #' rep("WEEK 2", 2),
- |
- ||
| 37 | -- |
- #' rep("WEEK 1", 2),
- |
- ||
| 38 | -- |
- #' rep("WEEK 2", 2),
- |
- ||
| 39 | -- |
- #' rep("WEEK 1", 2),
- |
- ||
| 40 | -- |
- #' rep("WEEK 2", 2)
- |
- ||
| 41 | -- |
- #' ),- |
- ||
| 42 | -- |
- #' PARAM = rep(c("ALT", "CPR"), 6),
- |
- ||
| 43 | -- |
- #' ANRIND = c(- |
- ||
| 44 | -- |
- #' "NORMAL", "NORMAL", "LOW",- |
- ||
| 45 | -- |
- #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
- |
- ||
| 46 | -- |
- #' ),- |
- ||
| 47 | -- |
- #' ANRLO = rep(5, 12),- |
- ||
| 48 | -- |
- #' ANRHI = rep(20, 12)- |
- ||
| 49 | -- |
- #' )- |
- ||
| 50 | -- |
- #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
- |
- ||
| 51 | -- |
- #' h_map_for_count_abnormal(- |
- ||
| 52 | -- |
- #' df = df,- |
- ||
| 53 | -- |
- #' variables = list(- |
- ||
| 54 | -- |
- #' anl = "ANRIND",- |
- ||
| 55 | -- |
- #' split_rows = c("PARAM"),
- |
- ||
| 56 | -- |
- #' range_low = "ANRLO",- |
- ||
| 57 | -- |
- #' range_high = "ANRHI"- |
- ||
| 58 | -- |
- #' ),- |
- ||
| 59 | -- |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
- |
- ||
| 60 | -- |
- #' method = "range",- |
- ||
| 61 | +189 |
- #' na_str = "<Missing>"+ #' # Extract hazard ratio for one group with stratification factor. |
||
| 62 | +190 |
- #' )+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1) |
||
| 63 | +191 |
#' |
||
| 64 | +192 |
#' @export |
||
| 65 | -- |
- h_map_for_count_abnormal <- function(df,- |
- ||
| 66 | -- |
- variables = list(- |
- ||
| 67 | -- |
- anl = "ANRIND",- |
- ||
| 68 | -- |
- split_rows = c("PARAM"),
- |
- ||
| 69 | -- |
- range_low = "ANRLO",- |
- ||
| 70 | -- |
- range_high = "ANRHI"- |
- ||
| 71 | -- |
- ),- |
- ||
| 72 | -- |
- abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
- |
- ||
| 73 | -- |
- method = c("default", "range"),
- |
- ||
| 74 | -- |
- na_level = lifecycle::deprecated(),- |
- ||
| 75 | +193 |
- na_str = "<Missing>") {
+ h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
|
||
| 76 | -7x | -
- if (lifecycle::is_present(na_level)) {
- |
- ||
| 77 | -! | +194 | +64x |
- lifecycle::deprecate_warn("0.9.1", "h_map_for_count_abnormal(na_level)", "h_map_for_count_abnormal(na_str)")
+ checkmate::assert_numeric(tte) |
| 78 | -! | +|||
| 195 | +64x |
- na_str <- na_level+ checkmate::assert_logical(is_event, len = length(tte)) |
||
| 79 | -+ | |||
| 196 | +64x |
- }+ assert_valid_factor(arm, n.levels = 2, len = length(tte)) |
||
| 80 | +197 | |||
| 81 | -7x | -
- method <- match.arg(method)- |
- ||
| 82 | -7x | -
- checkmate::assert_subset(c("anl", "split_rows"), names(variables))
- |
- ||
| 83 | -7x | +198 | +64x |
- checkmate::assert_false(anyNA(df[variables$split_rows]))+ df_tte <- data.frame(tte = tte, is_event = is_event) |
| 84 | -7x | +199 | +64x |
- assert_df_with_variables(df,+ strata_vars <- NULL |
| 85 | -7x | +|||
| 200 | +
- variables = list(anl = variables$anl, split_rows = variables$split_rows),+ |
|||
| 86 | -7x | -
- na_level = na_str- |
- ||
| 87 | -+ | 201 | +64x |
- )+ if (!is.null(strata_data)) {
|
| 88 | -7x | +202 | +5x |
- assert_df_with_factors(df, list(val = variables$anl))+ if (is.data.frame(strata_data)) {
|
| 89 | -7x | +203 | +4x |
- assert_valid_factor(df[[variables$anl]], any.missing = FALSE)+ strata_vars <- names(strata_data) |
| 90 | -7x | +204 | +4x |
- assert_list_of_variables(variables)+ checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte)) |
| 91 | -7x | +205 | +4x |
- checkmate::assert_list(abnormal, types = "character", len = 2)+ assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars))) |
| 92 | +206 |
-
+ } else {
|
||
| 93 | -+ | |||
| 207 | +1x |
- # Drop usued levels from df as they are not supposed to be in the final map+ assert_valid_factor(strata_data, len = nrow(df_tte)) |
||
| 94 | -7x | +208 | +1x |
- df <- droplevels(df)+ strata_vars <- "strata_data" |
| 95 | +209 |
-
+ } |
||
| 96 | -7x | +210 | +5x |
- normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))+ df_tte[strata_vars] <- strata_data |
| 97 | +211 |
-
+ } |
||
| 98 | +212 |
- # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL"+ |
||
| 99 | -7x | +213 | +64x |
- checkmate::assert_vector(normal_value, len = 1)+ l_df <- split(df_tte, arm) |
| 100 | +214 | |||
| 101 | -+ | |||
| 215 | +64x |
- # Default method will only have what is observed in the df, and records with all normal values will be excluded to+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
||
| 102 | +216 |
- # avoid error in layout building.+ # Hazard ratio and CI. |
||
| 103 | -7x | +217 | +60x |
- if (method == "default") {
+ result <- s_coxph_pairwise( |
| 104 | -3x | +218 | +60x |
- df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal))+ df = l_df[[2]], |
| 105 | -3x | +219 | +60x |
- map <- unique(df_abnormal[c(variables$split_rows, variables$anl)])+ .ref_group = l_df[[1]], |
| 106 | -3x | +220 | +60x |
- map_normal <- unique(subset(map, select = variables$split_rows))+ .in_ref_col = FALSE, |
| 107 | -3x | +221 | +60x |
- map_normal[[variables$anl]] <- normal_value+ .var = "tte", |
| 108 | -3x | +222 | +60x |
- map <- rbind(map, map_normal)+ is_event = "is_event", |
| 109 | -4x | +223 | +60x |
- } else if (method == "range") {
+ strata = strata_vars, |
| 110 | -+ | |||
| 224 | +60x |
- # range method follows the rule that at least one observation with ANRLO > 0 for low+ control = control |
||
| 111 | +225 |
- # direction and at least one observation with ANRHI is not missing for high direction.+ ) |
||
| 112 | -4x | +|||
| 226 | +
- checkmate::assert_subset(c("range_low", "range_high"), names(variables))
+
|
|||
| 113 | -4x | +227 | +60x |
- checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
+ df <- data.frame( |
| 114 | +228 |
-
+ # Dummy column needed downstream to create a nested header. |
||
| 115 | -4x | +229 | +60x |
- assert_df_with_variables(df,+ arm = " ", |
| 116 | -4x | +230 | +60x |
- variables = list(+ n_tot = unname(as.numeric(result$n_tot)), |
| 117 | -4x | +231 | +60x |
- range_low = variables$range_low,+ n_tot_events = unname(as.numeric(result$n_tot_events)), |
| 118 | -4x | +232 | +60x |
- range_high = variables$range_high+ hr = unname(as.numeric(result$hr)), |
| 119 | -+ | |||
| 233 | +60x |
- )+ lcl = unname(result$hr_ci[1]), |
||
| 120 | -+ | |||
| 234 | +60x |
- )+ ucl = unname(result$hr_ci[2]), |
||
| 121 | -+ | |||
| 235 | +60x |
-
+ conf_level = control[["conf_level"]], |
||
| 122 | -+ | |||
| 236 | +60x |
- # Define low direction of map+ pval = as.numeric(result$pvalue), |
||
| 123 | -4x | +237 | +60x |
- df_low <- subset(df, df[[variables$range_low]] > 0)+ pval_label = obj_label(result$pvalue), |
| 124 | -4x | +238 | +60x |
- map_low <- unique(df_low[variables$split_rows])+ stringsAsFactors = FALSE |
| 125 | -4x | +|||
| 239 | +
- low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"]))+ ) |
|||
| 126 | -4x | +|||
| 240 | +
- low_levels_df <- as.data.frame(low_levels)+ } else if ( |
|||
| 127 | +241 | 4x |
- colnames(low_levels_df) <- variables$anl+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
|
| 128 | +242 | 4x |
- low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
|
| 129 | -4x | +|||
| 243 | +
- rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed+ ) {
|
|||
| 130 | +244 | 4x |
- map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE]+ df_tte_complete <- df_tte[stats::complete.cases(df_tte), ] |
|
| 131 | +245 | 4x |
- map_low <- cbind(map_low, low_levels_df)- |
- |
| 132 | -- |
-
+ df <- data.frame( |
||
| 133 | +246 |
- # Define high direction of map- |
- ||
| 134 | -4x | -
- df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]]))+ # Dummy column needed downstream to create a nested header. |
||
| 135 | +247 | 4x |
- map_high <- unique(df_high[variables$split_rows])+ arm = " ", |
|
| 136 | +248 | 4x |
- high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"]))+ n_tot = nrow(df_tte_complete), |
|
| 137 | +249 | 4x |
- high_levels_df <- as.data.frame(high_levels)+ n_tot_events = sum(df_tte_complete$is_event), |
|
| 138 | +250 | 4x |
- colnames(high_levels_df) <- variables$anl+ hr = NA, |
|
| 139 | +251 | 4x |
- high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
+ lcl = NA, |
|
| 140 | +252 | 4x |
- rownames(map_high) <- NULL+ ucl = NA, |
|
| 141 | +253 | 4x |
- map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE]+ conf_level = control[["conf_level"]], |
|
| 142 | +254 | 4x |
- map_high <- cbind(map_high, high_levels_df)- |
- |
| 143 | -- | - - | -||
| 144 | -- |
- # Define normal of map+ pval = NA, |
||
| 145 | +255 | 4x |
- map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])+ pval_label = NA, |
|
| 146 | +256 | 4x |
- map_normal[variables$anl] <- normal_value+ stringsAsFactors = FALSE |
|
| 147 | +257 |
-
+ ) |
||
| 148 | -4x | +|||
| 258 | +
- map <- rbind(map_low, map_high, map_normal)+ } else {
|
|||
| 149 | -+ | |||
| 259 | +! |
- }+ df <- data.frame( |
||
| 150 | +260 |
-
+ # Dummy column needed downstream to create a nested header. |
||
| 151 | -+ | |||
| 261 | +! |
- # map should be all characters+ arm = " ", |
||
| 152 | -7x | +|||
| 262 | +! |
- map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE)+ n_tot = 0L, |
||
| 153 | -+ | |||
| 263 | +! |
-
+ n_tot_events = 0L, |
||
| 154 | -+ | |||
| 264 | +! |
- # sort the map final output by split_rows variables+ hr = NA, |
||
| 155 | -7x | +|||
| 265 | +! |
- for (i in rev(seq_len(length(variables$split_rows)))) {
+ lcl = NA, |
||
| 156 | -7x | +|||
| 266 | +! |
- map <- map[order(map[[i]]), ]+ ucl = NA, |
||
| 157 | -+ | |||
| 267 | +! |
- }+ conf_level = control[["conf_level"]], |
||
| 158 | -7x | +|||
| 268 | +! |
- map+ pval = NA, |
||
| 159 | -+ | |||
| 269 | +! |
- }+ pval_label = NA, |
| 1 | -+ | |||
| 270 | +! |
- #' Create a STEP Graph+ stringsAsFactors = FALSE |
||
| 2 | +271 |
- #'+ ) |
||
| 3 | +272 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +273 |
- #'+ |
||
| 5 | -+ | |||
| 274 | +64x |
- #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR+ df |
||
| 6 | +275 |
- #' along the continuous biomarker value subgroups.+ } |
||
| 7 | +276 |
- #'+ |
||
| 8 | +277 |
- #' @param df (`tibble`)\cr result of [tidy.step()].+ #' @describeIn h_survival_duration_subgroups summarizes estimates of the treatment hazard ratio |
||
| 9 | +278 |
- #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual+ #' across subgroups in a data frame. `variables` corresponds to the names of variables found in |
||
| 10 | +279 |
- #' biomarker values.+ #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and |
||
| 11 | +280 |
- #' @param est (named `list`)\cr `col` and `lty` settings for estimate line.+ #' optionally `subgroups` and `strata`. `groups_lists` optionally specifies |
||
| 12 | +281 |
- #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval+ #' groupings for `subgroups` variables. |
||
| 13 | +282 |
- #' ribbon area, or `NULL` to not plot a CI ribbon.+ #' |
||
| 14 | +283 |
- #' @param col (`character`)\cr colors.+ #' @return |
||
| 15 | +284 |
- #'+ #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, |
||
| 16 | +285 |
- #' @return A `ggplot` STEP graph.+ #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 17 | +286 |
#' |
||
| 18 | +287 |
- #' @seealso Custom tidy method [tidy.step()].+ #' @examples |
||
| 19 | +288 |
- #'+ #' # Extract hazard ratio for multiple groups. |
||
| 20 | +289 |
- #' @examples+ #' h_coxph_subgroups_df( |
||
| 21 | +290 |
- #' library(nestcolor)+ #' variables = list( |
||
| 22 | +291 |
- #' library(survival)+ #' tte = "AVAL", |
||
| 23 | +292 |
- #' lung$sex <- factor(lung$sex)+ #' is_event = "is_event", |
||
| 24 | +293 |
- #'+ #' arm = "ARM", |
||
| 25 | +294 |
- #' # Survival example.+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 26 | +295 |
- #' vars <- list(+ #' ), |
||
| 27 | +296 |
- #' time = "time",+ #' data = adtte_f |
||
| 28 | +297 |
- #' event = "status",+ #' ) |
||
| 29 | +298 |
- #' arm = "sex",+ #' |
||
| 30 | +299 |
- #' biomarker = "age"+ #' # Define groupings of BMRKR2 levels. |
||
| 31 | +300 |
- #' )+ #' h_coxph_subgroups_df( |
||
| 32 | +301 |
- #'+ #' variables = list( |
||
| 33 | +302 |
- #' step_matrix <- fit_survival_step(+ #' tte = "AVAL", |
||
| 34 | +303 |
- #' variables = vars,+ #' is_event = "is_event", |
||
| 35 | +304 |
- #' data = lung,+ #' arm = "ARM", |
||
| 36 | +305 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 37 | +306 |
- #' )+ #' ), |
||
| 38 | +307 |
- #' step_data <- broom::tidy(step_matrix)+ #' data = adtte_f, |
||
| 39 | +308 |
- #'+ #' groups_lists = list( |
||
| 40 | +309 |
- #' # Default plot.+ #' BMRKR2 = list( |
||
| 41 | +310 |
- #' g_step(step_data)+ #' "low" = "LOW", |
||
| 42 | +311 |
- #'+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 43 | +312 |
- #' # Add the reference 1 horizontal line.+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 44 | +313 |
- #' library(ggplot2)+ #' ) |
||
| 45 | +314 |
- #' g_step(step_data) ++ #' ) |
||
| 46 | +315 |
- #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)+ #' ) |
||
| 47 | +316 |
#' |
||
| 48 | +317 |
- #' # Use actual values instead of percentiles, different color for estimate and no CI,+ #' # Extract hazard ratio for multiple groups with stratification factors. |
||
| 49 | +318 |
- #' # use log scale for y axis.+ #' h_coxph_subgroups_df( |
||
| 50 | +319 |
- #' g_step(+ #' variables = list( |
||
| 51 | +320 |
- #' step_data,+ #' tte = "AVAL", |
||
| 52 | +321 |
- #' use_percentile = FALSE,+ #' is_event = "is_event", |
||
| 53 | +322 |
- #' est = list(col = "blue", lty = 1),+ #' arm = "ARM", |
||
| 54 | +323 |
- #' ci_ribbon = NULL+ #' subgroups = c("SEX", "BMRKR2"),
|
||
| 55 | +324 |
- #' ) + scale_y_log10()+ #' strata = c("STRATA1", "STRATA2")
|
||
| 56 | +325 |
- #'+ #' ), |
||
| 57 | +326 |
- #' # Adding another curve based on additional column.+ #' data = adtte_f |
||
| 58 | +327 |
- #' step_data$extra <- exp(step_data$`Percentile Center`)+ #' ) |
||
| 59 | +328 |
- #' g_step(step_data) ++ #' |
||
| 60 | +329 |
- #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")+ #' @export |
||
| 61 | +330 |
- #'+ h_coxph_subgroups_df <- function(variables, |
||
| 62 | +331 |
- #' # Response example.+ data, |
||
| 63 | +332 |
- #' vars <- list(+ groups_lists = list(), |
||
| 64 | +333 |
- #' response = "status",+ control = control_coxph(), |
||
| 65 | +334 |
- #' arm = "sex",+ label_all = "All Patients") {
|
||
| 66 | -+ | |||
| 335 | +13x |
- #' biomarker = "age"+ if ("strat" %in% names(variables)) {
|
||
| 67 | -+ | |||
| 336 | +! |
- #' )+ warning( |
||
| 68 | -+ | |||
| 337 | +! |
- #'+ "Warning: the `strat` element name of the `variables` list argument to `h_coxph_subgroups_df() ", |
||
| 69 | -+ | |||
| 338 | +! |
- #' step_matrix <- fit_rsp_step(+ "was deprecated in tern 0.9.3.\n ", |
||
| 70 | -+ | |||
| 339 | +! |
- #' variables = vars,+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 71 | +340 |
- #' data = lung,+ ) |
||
| 72 | -+ | |||
| 341 | +! |
- #' control = c(+ variables[["strata"]] <- variables[["strat"]] |
||
| 73 | +342 |
- #' control_logistic(response_definition = "I(response == 2)"),+ } |
||
| 74 | +343 |
- #' control_step()+ |
||
| 75 | -+ | |||
| 344 | +13x |
- #' )+ checkmate::assert_character(variables$tte) |
||
| 76 | -+ | |||
| 345 | +13x |
- #' )+ checkmate::assert_character(variables$is_event) |
||
| 77 | -+ | |||
| 346 | +13x |
- #' step_data <- broom::tidy(step_matrix)+ checkmate::assert_character(variables$arm) |
||
| 78 | -+ | |||
| 347 | +13x |
- #' g_step(step_data)+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 79 | -+ | |||
| 348 | +13x |
- #'+ checkmate::assert_character(variables$strata, null.ok = TRUE) |
||
| 80 | -+ | |||
| 349 | +13x |
- #' @export+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
||
| 81 | -+ | |||
| 350 | +13x |
- g_step <- function(df,+ assert_df_with_variables(data, variables) |
||
| 82 | -+ | |||
| 351 | +13x |
- use_percentile = "Percentile Center" %in% names(df),+ checkmate::assert_string(label_all) |
||
| 83 | +352 |
- est = list(col = "blue", lty = 1),+ |
||
| 84 | +353 |
- ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
+ # Add All Patients. |
||
| 85 | -+ | |||
| 354 | +13x |
- col = getOption("ggplot2.discrete.colour")) {
+ result_all <- h_coxph_df( |
||
| 86 | -2x | +355 | +13x |
- checkmate::assert_tibble(df)+ tte = data[[variables$tte]], |
| 87 | -2x | +356 | +13x |
- checkmate::assert_flag(use_percentile)+ is_event = data[[variables$is_event]], |
| 88 | -2x | +357 | +13x |
- checkmate::assert_character(col, null.ok = TRUE)+ arm = data[[variables$arm]], |
| 89 | -2x | +358 | +13x |
- checkmate::assert_list(est, names = "named")+ strata_data = if (is.null(variables$strata)) NULL else data[variables$strata], |
| 90 | -2x | +359 | +13x |
- checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE)+ control = control |
| 91 | +360 |
-
+ ) |
||
| 92 | -2x | +361 | +13x |
- x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center")+ result_all$subgroup <- label_all |
| 93 | -2x | +362 | +13x |
- df$x <- df[[x_var]]+ result_all$var <- "ALL" |
| 94 | -2x | +363 | +13x |
- attrs <- attributes(df)+ result_all$var_label <- label_all |
| 95 | -2x | +364 | +13x |
- df$y <- df[[attrs$estimate]]+ result_all$row_type <- "content" |
| 96 | +365 | |||
| 97 | +366 |
- # Set legend names. To be modified also at call level+ # Add Subgroups. |
||
| 98 | -2x | +367 | +13x |
- legend_names <- c("Estimate", "CI 95%")
+ if (is.null(variables$subgroups)) {
+ |
+
| 368 | +3x | +
+ result_all |
||
| 99 | +369 |
-
+ } else {
|
||
| 100 | -2x | +370 | +10x |
- p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]]))+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 101 | +371 | |||
| 102 | -2x | +372 | +10x |
- if (!is.null(col)) {
+ l_result <- lapply(l_data, function(grp) {
|
| 103 | -2x | +373 | +47x |
- p <- p ++ result <- h_coxph_df( |
| 104 | -2x | -
- ggplot2::scale_color_manual(values = col)- |
- ||
| 105 | -+ | 374 | +47x |
- }+ tte = grp$df[[variables$tte]], |
| 106 | -+ | |||
| 375 | +47x |
-
+ is_event = grp$df[[variables$is_event]], |
||
| 107 | -2x | +376 | +47x |
- if (!is.null(ci_ribbon)) {
+ arm = grp$df[[variables$arm]], |
| 108 | -1x | +377 | +47x |
- if (is.null(ci_ribbon$fill)) {
+ strata_data = if (is.null(variables$strata)) NULL else grp$df[variables$strata], |
| 109 | -! | +|||
| 378 | +47x |
- ci_ribbon$fill <- "lightblue"+ control = control |
||
| 110 | +379 |
- }- |
- ||
| 111 | -1x | -
- p <- p + ggplot2::geom_ribbon(- |
- ||
| 112 | -1x | -
- ggplot2::aes(+ ) |
||
| 113 | -1x | +380 | +47x |
- ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]],+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 114 | -1x | +381 | +47x |
- fill = legend_names[2]+ cbind(result, result_labels) |
| 115 | +382 |
- ),- |
- ||
| 116 | -1x | -
- alpha = ci_ribbon$alpha+ }) |
||
| 117 | +383 |
- ) +- |
- ||
| 118 | -1x | -
- scale_fill_manual(+ |
||
| 119 | -1x | +384 | +10x |
- name = "", values = c("CI 95%" = ci_ribbon$fill)
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 120 | -+ | |||
| 385 | +10x |
- )+ result_subgroups$row_type <- "analysis" |
||
| 121 | +386 |
- }+ |
||
| 122 | -2x | +387 | +10x |
- suppressMessages(p <- p ++ rbind( |
| 123 | -2x | +388 | +10x |
- ggplot2::geom_line(+ result_all, |
| 124 | -2x | +389 | +10x |
- ggplot2::aes(y = .data[["y"]], color = legend_names[1]),+ result_subgroups |
| 125 | -2x | +|||
| 390 | +
- linetype = est$lty+ ) |
|||
| 126 | +391 |
- ) ++ } |
||
| 127 | -2x | +|||
| 392 | +
- scale_colour_manual(+ } |
|||
| 128 | -2x | +|||
| 393 | +
- name = "", values = c("Estimate" = "blue")
+
|
|||
| 129 | +394 |
- ))+ #' Split Dataframe by Subgroups |
||
| 130 | +395 |
-
+ #' |
||
| 131 | -2x | +|||
| 396 | +
- p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 132 | -2x | +|||
| 397 | +
- if (use_percentile) {
+ #' |
|||
| 133 | -1x | +|||
| 398 | +
- p <- p + ggplot2::scale_x_continuous(labels = scales::percent)+ #' Split a dataframe into a non-nested list of subsets. |
|||
| 134 | +399 |
- }+ #' |
||
| 135 | -2x | +|||
| 400 | +
- p+ #' @inheritParams argument_convention |
|||
| 136 | +401 |
- }+ #' @inheritParams survival_duration_subgroups |
||
| 137 | +402 |
-
+ #' @param data (`data.frame`)\cr dataset to split. |
||
| 138 | +403 |
- #' Custom Tidy Method for STEP Results+ #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets. |
||
| 139 | +404 |
- #'+ #' Unused levels not present in `data` are dropped. Note that the order in this vector |
||
| 140 | +405 |
- #' @description `r lifecycle::badge("stable")`
+ #' determines the order in the downstream table. |
||
| 141 | +406 |
#' |
||
| 142 | +407 |
- #' Tidy the STEP results into a `tibble` format ready for plotting.+ #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`). |
||
| 143 | +408 |
#' |
||
| 144 | +409 |
- #' @param x (`step` matrix)\cr results from [fit_survival_step()].+ #' @details Main functionality is to prepare data for use in forest plot layouts. |
||
| 145 | +410 |
- #' @param ... not used here.+ #' |
||
| 146 | +411 |
- #'+ #' @examples |
||
| 147 | +412 |
- #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,+ #' df <- data.frame( |
||
| 148 | +413 |
- #' respectively. Additional attributes carry metadata also used for plotting.+ #' x = c(1:5), |
||
| 149 | +414 |
- #'+ #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
|
||
| 150 | +415 |
- #' @seealso [g_step()] which consumes the result from this function.+ #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
|
||
| 151 | +416 |
- #'+ #' ) |
||
| 152 | +417 |
- #' @method tidy step+ #' formatters::var_labels(df) <- paste("label for", names(df))
|
||
| 153 | +418 |
#' |
||
| 154 | +419 |
- #' @examples+ #' h_split_by_subgroups( |
||
| 155 | +420 |
- #' library(survival)+ #' data = df, |
||
| 156 | +421 |
- #' lung$sex <- factor(lung$sex)+ #' subgroups = c("y", "z")
|
||
| 157 | +422 |
- #' vars <- list(+ #' ) |
||
| 158 | +423 |
- #' time = "time",+ #' |
||
| 159 | +424 |
- #' event = "status",+ #' h_split_by_subgroups( |
||
| 160 | +425 |
- #' arm = "sex",+ #' data = df, |
||
| 161 | +426 |
- #' biomarker = "age"+ #' subgroups = c("y", "z"),
|
||
| 162 | +427 |
- #' )+ #' groups_lists = list( |
||
| 163 | +428 |
- #' step_matrix <- fit_survival_step(+ #' y = list("AB" = c("A", "B"), "C" = "C")
|
||
| 164 | +429 |
- #' variables = vars,+ #' ) |
||
| 165 | +430 |
- #' data = lung,+ #' ) |
||
| 166 | +431 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' |
||
| 167 | +432 |
- #' )+ #' @export |
||
| 168 | +433 |
- #' broom::tidy(step_matrix)+ h_split_by_subgroups <- function(data, |
||
| 169 | +434 |
- #'+ subgroups, |
||
| 170 | +435 |
- #' @export+ groups_lists = list()) {
+ |
+ ||
| 436 | +52x | +
+ checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)+ |
+ ||
| 437 | +52x | +
+ checkmate::assert_list(groups_lists, names = "named")+ |
+ ||
| 438 | +52x | +
+ checkmate::assert_subset(names(groups_lists), subgroups)+ |
+ ||
| 439 | +52x | +
+ assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups))) |
||
| 171 | +440 |
- tidy.step <- function(x, ...) { # nolint
+
|
||
| 172 | -7x | +441 | +52x |
- checkmate::assert_class(x, "step")+ data_labels <- unname(formatters::var_labels(data)) |
| 173 | -7x | +442 | +52x |
- dat <- as.data.frame(x)+ df_subgroups <- data[, subgroups, drop = FALSE] |
| 174 | -7x | +443 | +52x |
- nams <- names(dat)+ subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)+ |
+
| 444 | ++ | + | ||
| 175 | -7x | +445 | +52x |
- is_surv <- "loghr" %in% names(dat)+ l_labels <- Map(function(grp_i, name_i) {
|
| 176 | -7x | +446 | +93x |
- est_var <- ifelse(is_surv, "loghr", "logor")+ existing_levels <- levels(droplevels(grp_i)) |
| 177 | -7x | +447 | +93x |
- new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio")+ grp_levels <- if (name_i %in% names(groups_lists)) {
+ |
+
| 448 | ++ |
+ # For this variable groupings are defined. We check which groups are contained in the data. |
||
| 178 | -7x | +449 | +11x |
- new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
+ group_list_i <- groups_lists[[name_i]] |
| 179 | -7x | +450 | +11x |
- names(dat)[match(est_var, nams)] <- new_est_var+ group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE) |
| 180 | -7x | +451 | +11x |
- dat[, new_y_vars] <- exp(dat[, new_y_vars])+ names(which(group_has_levels))+ |
+
| 452 | ++ |
+ } else {
|
||
| 181 | -7x | +453 | +82x |
- any_is_na <- any(is.na(dat[, new_y_vars]))+ existing_levels+ |
+
| 454 | ++ |
+ } |
||
| 182 | -7x | +455 | +93x |
- any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE)+ df_labels <- data.frame( |
| 183 | -7x | +456 | +93x |
- if (any_is_na) {
+ subgroup = grp_levels, |
| 184 | -2x | +457 | +93x |
- warning(paste(+ var = name_i, |
| 185 | -2x | +458 | +93x |
- "Missing values in the point estimate or CI columns,",+ var_label = unname(subgroup_labels[name_i]), |
| 186 | -2x | +459 | +93x |
- "this will lead to holes in the `g_step()` plot"+ stringsAsFactors = FALSE # Rationale is that subgroups may not be unique. |
| 187 | +460 |
- ))+ )+ |
+ ||
| 461 | +52x | +
+ }, df_subgroups, names(df_subgroups)) |
||
| 188 | +462 |
- }+ |
||
| 189 | -7x | +|||
| 463 | +
- if (any_is_very_large) {
+ # Create a dataframe with one row per subgroup. |
|||
| 190 | -2x | +464 | +52x |
- warning(paste(+ df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE)) |
| 191 | -2x | +465 | +52x |
- "Very large absolute values in the point estimate or CI columns,",+ row_label <- paste0(df_labels$var, ".", df_labels$subgroup) |
| 192 | -2x | +466 | +52x |
- "consider adding `scale_y_log10()` to the `g_step()` result for plotting"+ row_split_var <- factor(row_label, levels = row_label) |
| 193 | +467 |
- ))+ |
||
| 194 | +468 |
- }+ # Create a list of data subsets. |
||
| 195 | -7x | +469 | +52x |
- if (any_is_na || any_is_very_large) {
+ lapply(split(df_labels, row_split_var), function(row_i) {
|
| 196 | -4x | +470 | +233x |
- warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
+ which_row <- if (row_i$var %in% names(groups_lists)) {
+ |
+
| 471 | +31x | +
+ data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]] |
||
| 197 | +472 |
- }+ } else {
|
||
| 198 | -7x | +473 | +202x |
- structure(+ data[[row_i$var]] == row_i$subgroup+ |
+
| 474 | ++ |
+ } |
||
| 199 | -7x | +475 | +233x |
- tibble::as_tibble(dat),+ df <- data[which_row, ] |
| 200 | -7x | +476 | +233x |
- estimate = new_est_var,+ rownames(df) <- NULL |
| 201 | -7x | +477 | +233x |
- biomarker = attr(x, "variables")$biomarker,+ formatters::var_labels(df) <- data_labels+ |
+
| 478 | ++ | + | ||
| 202 | -7x | +479 | +233x |
- ci = f_conf_level(attr(x, "control")$conf_level)+ list(+ |
+
| 480 | +233x | +
+ df = df,+ |
+ ||
| 481 | +233x | +
+ df_labels = data.frame(row_i, row.names = NULL) |
||
| 203 | +482 |
- )+ ) |
||
| 204 | +483 | ++ |
+ })+ |
+ |
| 484 |
}@@ -57034,14 +58768,14 @@ tern coverage - 90.46% |
| 1 |
- #' Confidence Intervals for a Difference of Binomials+ #' Counting Patients and Events in Columns |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Several confidence intervals for the difference between proportions.+ #' Counting the number of unique patients and the total number of all and specific events |
||
| 6 |
- #'+ #' when a column table layout is required. |
||
| 7 |
- #' @name desctools_binom+ #' |
||
| 8 |
- NULL+ #' @inheritParams argument_convention |
||
| 9 |
-
+ #' @param filters_list (named `list` of `character`)\cr each element in this list describes one |
||
| 10 |
- #' Recycle List of Parameters+ #' type of event describe by filters, in the same format as [s_count_patients_with_event()]. |
||
| 11 |
- #'+ #' If it has a label, then this will be used for the column title. |
||
| 12 |
- #' This function recycles all supplied elements to the maximal dimension.+ #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such |
||
| 13 |
- #'+ #' that corresponding table cells will stay blank. |
||
| 14 |
- #' @param ... (`any`)\cr Elements to recycle.+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will |
||
| 15 |
- #'+ #' be used as label. |
||
| 16 |
- #' @return A `list`.+ #' @param .stats (`character`)\cr statistics to select for the table. Run |
||
| 17 |
- #'+ #' `get_stats("summarize_patients_events_in_cols")` to see available statistics for this function, in addition
|
||
| 18 |
- #' @keywords internal+ #' to any added using `filters_list`. |
||
| 19 |
- #' @noRd+ #' |
||
| 20 |
- h_recycle <- function(...) {
+ #' @name count_patients_events_in_cols |
||
| 21 | -64x | +
- lst <- list(...)+ #' @order 1 |
|
| 22 | -64x | +
- maxdim <- max(lengths(lst))+ NULL |
|
| 23 | -64x | +
- res <- lapply(lst, rep, length.out = maxdim)+ |
|
| 24 | -64x | +
- attr(res, "maxdim") <- maxdim+ #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple |
|
| 25 | -64x | +
- return(res)+ #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`. |
|
| 26 |
- }+ #' |
||
| 27 |
-
+ #' @return |
||
| 28 |
- #' @describeIn desctools_binom Several confidence intervals for the difference between proportions.+ #' * `s_count_patients_and_multiple_events()` returns a list with the statistics: |
||
| 29 |
- #'+ #' - `unique`: number of unique patients in `df`. |
||
| 30 |
- #' @return A `matrix` of 3 values:+ #' - `all`: number of rows in `df`. |
||
| 31 |
- #' * `est`: estimate of proportion difference.+ #' - one element with the same name as in `filters_list`: number of rows in `df`, |
||
| 32 |
- #' * `lwr.ci`: estimate of lower end of the confidence interval.+ #' i.e. events, fulfilling the filter condition. |
||
| 33 |
- #' * `upr.ci`: estimate of upper end of the confidence interval.+ #' |
||
| 34 |
- #'+ #' @keywords internal |
||
| 35 |
- #' @keywords internal+ s_count_patients_and_multiple_events <- function(df, # nolint |
||
| 36 |
- desctools_binom <- function(x1,+ id, |
||
| 37 |
- n1,+ filters_list, |
||
| 38 |
- x2,+ empty_stats = character(), |
||
| 39 |
- n2,+ labelstr = "", |
||
| 40 |
- conf.level = 0.95, # nolint+ custom_label = NULL) {
|
||
| 41 | -+ | 9x |
- sides = c("two.sided", "left", "right"),
+ checkmate::assert_list(filters_list, names = "named") |
| 42 | -+ | 9x |
- method = c(+ checkmate::assert_data_frame(df) |
| 43 | -+ | 9x |
- "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"+ checkmate::assert_string(id) |
| 44 | -+ | 9x |
- )) {
+ checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
|
| 45 | -20x | +9x |
- if (missing(sides)) {
+ checkmate::assert_character(empty_stats) |
| 46 | -20x | +9x |
- sides <- match.arg(sides)+ checkmate::assert_string(labelstr) |
| 47 | -+ | 9x |
- }+ checkmate::assert_string(custom_label, null.ok = TRUE) |
| 48 | -20x | +
- if (missing(method)) {
+
|
|
| 49 | -1x | +
- method <- match.arg(method)+ # Below we want to count each row in `df` once, therefore introducing this helper index column. |
|
| 50 | -+ | 9x |
- }+ df$.row_index <- as.character(seq_len(nrow(df))) |
| 51 | -20x | +9x |
- iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint
+ y <- list() |
| 52 | -20x | +9x |
- if (sides != "two.sided") {
+ row_label <- if (labelstr != "") {
|
| 53 | ! |
- conf.level <- 1 - 2 * (1 - conf.level) # nolint+ labelstr |
|
| 54 | -+ | 9x |
- }+ } else if (!is.null(custom_label)) {
|
| 55 | -20x | +2x |
- alpha <- 1 - conf.level+ custom_label |
| 56 | -20x | +
- kappa <- stats::qnorm(1 - alpha / 2)+ } else {
|
|
| 57 | -20x | +7x |
- p1_hat <- x1 / n1+ "counts" |
| 58 | -20x | +
- p2_hat <- x2 / n2+ } |
|
| 59 | -20x | +9x |
- est <- p1_hat - p2_hat+ y$unique <- formatters::with_label( |
| 60 | -20x | +9x |
- switch(method,+ s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L], |
| 61 | -20x | +9x |
- wald = {
+ row_label |
| 62 | -2x | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ ) |
|
| 63 | -2x | +9x |
- term2 <- kappa * sqrt(vd)+ y$all <- formatters::with_label( |
| 64 | -2x | +9x |
- ci_lwr <- max(-1, est - term2)+ nrow(df), |
| 65 | -2x | +9x |
- ci_upr <- min(1, est + term2)+ row_label |
| 66 |
- },+ ) |
||
| 67 | -20x | +9x |
- waldcc = {
+ events <- Map( |
| 68 | -4x | +9x |
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ function(filters) {
|
| 69 | -4x | +25x |
- term2 <- kappa * sqrt(vd)+ formatters::with_label( |
| 70 | -4x | +25x |
- term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)+ s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count, |
| 71 | -4x | +25x |
- ci_lwr <- max(-1, est - term2)+ row_label |
| 72 | -4x | +
- ci_upr <- min(1, est + term2)+ ) |
|
| 73 |
- },+ }, |
||
| 74 | -20x | +9x |
- ac = {
+ filters = filters_list |
| 75 | -2x | +
- n1 <- n1 + 2+ ) |
|
| 76 | -2x | +9x |
- n2 <- n2 + 2+ y_complete <- c(y, events) |
| 77 | -2x | +9x |
- x1 <- x1 + 1+ y <- if (length(empty_stats) > 0) {
|
| 78 | -2x | +3x |
- x2 <- x2 + 1+ y_reduced <- y_complete |
| 79 | -2x | +3x |
- p1_hat <- x1 / n1+ for (stat in intersect(names(y_complete), empty_stats)) {
|
| 80 | -2x | +4x |
- p2_hat <- x2 / n2+ y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]])) |
| 81 | -2x | +
- est1 <- p1_hat - p2_hat+ } |
|
| 82 | -2x | +3x |
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ y_reduced |
| 83 | -2x | +
- term2 <- kappa * sqrt(vd)+ } else {
|
|
| 84 | -2x | +6x |
- ci_lwr <- max(-1, est1 - term2)+ y_complete |
| 85 | -2x | +
- ci_upr <- min(1, est1 + term2)+ } |
|
| 86 | -+ | 9x |
- },+ y |
| 87 | -20x | +
- exact = {
+ } |
|
| 88 | -! | +
- ci_lwr <- NA+ |
|
| 89 | -! | +
- ci_upr <- NA+ #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function |
|
| 90 |
- },+ #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 91 | -20x | +
- score = {
+ #' |
|
| 92 | -2x | +
- w1 <- desctools_binomci(+ #' @param col_split (`flag`)\cr whether the columns should be split. |
|
| 93 | -2x | +
- x = x1, n = n1, conf.level = conf.level,+ #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe. |
|
| 94 | -2x | +
- method = "wilson"+ #' |
|
| 95 |
- )+ #' @return |
||
| 96 | -2x | +
- w2 <- desctools_binomci(+ #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions, |
|
| 97 | -2x | +
- x = x2, n = n2, conf.level = conf.level,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
|
| 98 | -2x | +
- method = "wilson"+ #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout. |
|
| 99 |
- )+ #' |
||
| 100 | -2x | +
- l1 <- w1[2]+ #' @examples |
|
| 101 | -2x | +
- u1 <- w1[3]+ #' df <- data.frame( |
|
| 102 | -2x | +
- l2 <- w2[2]+ #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
|
|
| 103 | -2x | +
- u2 <- w2[3]+ #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
|
|
| 104 | -2x | +
- ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2)+ #' AESER = rep("Y", 7),
|
|
| 105 | -2x | +
- ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2)+ #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
|
|
| 106 |
- },+ #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
|
||
| 107 | -20x | +
- scorecc = {
+ #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
|
|
| 108 | -1x | +
- w1 <- desctools_binomci(+ #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
|
|
| 109 | -1x | +
- x = x1, n = n1, conf.level = conf.level,+ #' ) |
|
| 110 | -1x | +
- method = "wilsoncc"+ #' |
|
| 111 |
- )+ #' # `summarize_patients_events_in_cols()` |
||
| 112 | -1x | +
- w2 <- desctools_binomci(+ #' basic_table() %>% |
|
| 113 | -1x | +
- x = x2, n = n2, conf.level = conf.level,+ #' summarize_patients_events_in_cols( |
|
| 114 | -1x | +
- method = "wilsoncc"+ #' filters_list = list( |
|
| 115 |
- )+ #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"), |
||
| 116 | -1x | +
- l1 <- w1[2]+ #' fatal = c(AESDTH = "Y"), |
|
| 117 | -1x | +
- u1 <- w1[3]+ #' fatal_related = c(AEREL = "Y", AESDTH = "Y") |
|
| 118 | -1x | +
- l2 <- w2[2]+ #' ), |
|
| 119 | -1x | +
- u2 <- w2[3]+ #' custom_label = "%s Total number of patients and events" |
|
| 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))+ #' build_table(df) |
|
| 122 |
- },+ #' |
||
| 123 | -20x | +
- mee = {
+ #' @export |
|
| 124 | -1x | +
- .score <- function(p1, n1, p2, n2, dif) {
+ #' @order 2 |
|
| 125 | -! | +
- if (dif > 1) dif <- 1+ summarize_patients_events_in_cols <- function(lyt, # nolint |
|
| 126 | -! | +
- if (dif < -1) dif <- -1+ id = "USUBJID", |
|
| 127 | -24x | +
- diff <- p1 - p2 - dif+ filters_list = list(), |
|
| 128 | -24x | +
- if (abs(diff) == 0) {
+ empty_stats = character(), |
|
| 129 | -! | +
- res <- 0+ na_str = default_na_str(), |
|
| 130 |
- } else {
+ ..., |
||
| 131 | -24x | +
- t <- n2 / n1+ .stats = c( |
|
| 132 | -24x | +
- a <- 1 + t+ "unique", |
|
| 133 | -24x | +
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ "all", |
|
| 134 | -24x | +
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ names(filters_list) |
|
| 135 | -24x | +
- d <- -p1 * dif * (1 + dif)+ ), |
|
| 136 | -24x | +
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ .labels = c( |
|
| 137 | -24x | +
- if (abs(v) < .Machine$double.eps) v <- 0+ unique = "Patients (All)", |
|
| 138 | -24x | +
- s <- sqrt((b / a / 3)^2 - c / a / 3)+ all = "Events (All)", |
|
| 139 | -24x | +
- u <- ifelse(v > 0, 1, -1) * s+ labels_or_names(filters_list) |
|
| 140 | -24x | +
- w <- (3.141592654 + acos(v / u^3)) / 3+ ), |
|
| 141 | -24x | +
- p1d <- 2 * u * cos(w) - b / a / 3+ col_split = TRUE) {
|
|
| 142 | -24x | +2x |
- p2d <- p1d - dif+ extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...) |
| 143 | -24x | +
- n <- n1 + n2+ |
|
| 144 | -24x | +2x |
- res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2)+ afun_list <- Map( |
| 145 | -+ | 2x |
- }+ function(stat) {
|
| 146 | -24x | +7x |
- return(sqrt(res))+ make_afun( |
| 147 | -+ | 7x |
- }+ s_count_patients_and_multiple_events, |
| 148 | -1x | +7x |
- pval <- function(delta) {
+ .stats = stat, |
| 149 | -24x | +7x |
- z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta)+ .formats = "xx." |
| 150 | -24x | +
- 2 * min(stats::pnorm(z), 1 - stats::pnorm(z))+ ) |
|
| 151 |
- }+ }, |
||
| 152 | -1x | +2x |
- ci_lwr <- max(-1, stats::uniroot(function(delta) {
+ stat = .stats |
| 153 | -12x | +
- pval(delta) - alpha+ ) |
|
| 154 | -1x | +2x |
- }, interval = c(-1 + 1e-06, est - 1e-06))$root)+ if (col_split) {
|
| 155 | -1x | +2x |
- ci_upr <- min(1, stats::uniroot(function(delta) {
+ lyt <- split_cols_by_multivar( |
| 156 | -12x | +2x |
- pval(delta) - alpha+ lyt = lyt, |
| 157 | -1x | +2x |
- }, interval = c(est + 1e-06, 1 - 1e-06))$root)+ vars = rep(id, length(.stats)), |
| 158 | -+ | 2x |
- },+ varlabels = .labels[.stats] |
| 159 | -20x | +
- blj = {
+ ) |
|
| 160 | -1x | +
- p1_dash <- (x1 + 0.5) / (n1 + 1)+ } |
|
| 161 | -1x | +2x |
- p2_dash <- (x2 + 0.5) / (n2 + 1)+ summarize_row_groups( |
| 162 | -1x | +2x |
- vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2+ lyt = lyt, |
| 163 | -1x | +2x |
- term2 <- kappa * sqrt(vd)+ cfun = afun_list, |
| 164 | -1x | +2x |
- est_dash <- p1_dash - p2_dash+ na_str = na_str, |
| 165 | -1x | +2x |
- ci_lwr <- max(-1, est_dash - term2)+ extra_args = extra_args |
| 166 | -1x | +
- ci_upr <- min(1, est_dash + term2)+ ) |
|
| 167 |
- },+ } |
||
| 168 | -20x | +
| 1 | +
- ha = {
+ #' Helper Function to create a map dataframe that can be used in `trim_levels_to_map` split function. |
|||
| 169 | -4x | +|||
| 2 | +
- term2 <- 1 /+ #' |
|||
| 170 | -4x | +|||
| 3 | +
- (2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1))+ #' @description `r lifecycle::badge("stable")`
|
|||
| 171 | -4x | +|||
| 4 | +
- ci_lwr <- max(-1, est - term2)+ #' |
|||
| 172 | -4x | +|||
| 5 | +
- ci_upr <- min(1, est + term2)+ #' Helper Function to create a map dataframe from the input dataset, which can be used as an argument in the |
|||
| 173 | +6 |
- },+ #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently. |
||
| 174 | -20x | +|||
| 7 | +
- mn = {
+ #' |
|||
| 175 | -1x | +|||
| 8 | +
- .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
+ #' @inheritParams argument_convention |
|||
| 176 | -2x | +|||
| 9 | +
- p1 <- x1 / n1+ #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of |
|||
| 177 | -2x | +|||
| 10 | +
- p2 <- x2 / n2+ #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or |
|||
| 178 | -2x | +|||
| 11 | +
- p_hat <- p1 - p2+ #' `abnormal = list(Low = "LOW", High = "HIGH"))` |
|||
| 179 | -2x | +|||
| 12 | +
- dp <- 1 + ifelse(lower, 1, -1) * p_hat+ #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`. |
|||
| 180 | -2x | +|||
| 13 | +
- i <- 1+ #' |
|||
| 181 | -2x | +|||
| 14 | +
- while (i <= 50) {
+ #' @return A map `data.frame`. |
|||
| 182 | -46x | +|||
| 15 | +
- dp <- 0.5 * dp+ #' |
|||
| 183 | -46x | +|||
| 16 | +
- y <- p_hat + ifelse(lower, -1, 1) * dp+ #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the |
|||
| 184 | -46x | +|||
| 17 | +
- score <- .score(p1, n1, p2, n2, y)+ #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is |
|||
| 185 | -46x | +|||
| 18 | +
- if (score < z) {
+ #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0 |
|||
| 186 | -20x | +|||
| 19 | +
- p_hat <- y+ #' for low direction and at least one observation with high range is not missing for high direction. |
|||
| 187 | +20 |
- }+ #' |
||
| 188 | -46x | +|||
| 21 | +
- if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
+ #' @examples |
|||
| 189 | -2x | +|||
| 22 | +
- (break)()+ #' adlb <- df_explicit_na(tern_ex_adlb) |
|||
| 190 | +23 |
- } else {
+ #' |
||
| 191 | -44x | +|||
| 24 | +
- i <- i + 1+ #' h_map_for_count_abnormal( |
|||
| 192 | +25 |
- }+ #' df = adlb, |
||
| 193 | +26 |
- }+ #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
|
||
| 194 | -2x | +|||
| 27 | +
- return(y)+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
|||
| 195 | +28 |
- }+ #' method = "default", |
||
| 196 | -1x | +|||
| 29 | +
- .score <- function(p1, n1, p2, n2, dif) {
+ #' na_str = "<Missing>" |
|||
| 197 | -46x | +|||
| 30 | +
- diff <- p1 - p2 - dif+ #' ) |
|||
| 198 | -46x | +|||
| 31 | +
- if (abs(diff) == 0) {
+ #' |
|||
| 199 | -! | +|||
| 32 | +
- res <- 0+ #' df <- data.frame( |
|||
| 200 | +33 |
- } else {
+ #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
|
||
| 201 | -46x | +|||
| 34 | +
- t <- n2 / n1+ #' AVISIT = c( |
|||
| 202 | -46x | +|||
| 35 | +
- a <- 1 + t+ #' rep("WEEK 1", 2),
|
|||
| 203 | -46x | +|||
| 36 | +
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ #' rep("WEEK 2", 2),
|
|||
| 204 | -46x | +|||
| 37 | +
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ #' rep("WEEK 1", 2),
|
|||
| 205 | -46x | +|||
| 38 | +
- d <- -p1 * dif * (1 + dif)+ #' rep("WEEK 2", 2),
|
|||
| 206 | -46x | +|||
| 39 | +
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ #' rep("WEEK 1", 2),
|
|||
| 207 | -46x | +|||
| 40 | +
- s <- sqrt((b / a / 3)^2 - c / a / 3)+ #' rep("WEEK 2", 2)
|
|||
| 208 | -46x | +|||
| 41 | +
- u <- ifelse(v > 0, 1, -1) * s+ #' ), |
|||
| 209 | -46x | +|||
| 42 | +
- w <- (3.141592654 + acos(v / u^3)) / 3+ #' PARAM = rep(c("ALT", "CPR"), 6),
|
|||
| 210 | -46x | +|||
| 43 | +
- p1d <- 2 * u * cos(w) - b / a / 3+ #' ANRIND = c( |
|||
| 211 | -46x | +|||
| 44 | +
- p2d <- p1d - dif+ #' "NORMAL", "NORMAL", "LOW", |
|||
| 212 | -46x | +|||
| 45 | +
- n <- n1 + n2+ #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
|
|||
| 213 | -46x | +|||
| 46 | +
- var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) * n / (n - 1)+ #' ), |
|||
| 214 | -46x | +|||
| 47 | +
- res <- diff^2 / var+ #' ANRLO = rep(5, 12), |
|||
| 215 | +48 |
- }+ #' ANRHI = rep(20, 12) |
||
| 216 | -46x | +|||
| 49 | +
- return(res)+ #' ) |
|||
| 217 | +50 |
- }+ #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
|
||
| 218 | -1x | +|||
| 51 | +
- z <- stats::qchisq(conf.level, 1)+ #' h_map_for_count_abnormal( |
|||
| 219 | -1x | +|||
| 52 | +
- ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))+ #' df = df, |
|||
| 220 | -1x | +|||
| 53 | +
- ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE))+ #' variables = list( |
|||
| 221 | +54 |
- },+ #' anl = "ANRIND", |
||
| 222 | -20x | +|||
| 55 | +
- beal = {
+ #' split_rows = c("PARAM"),
|
|||
| 223 | -! | +|||
| 56 | +
- a <- p1_hat + p2_hat+ #' range_low = "ANRLO", |
|||
| 224 | -! | +|||
| 57 | +
- b <- p1_hat - p2_hat+ #' range_high = "ANRHI" |
|||
| 225 | -! | +|||
| 58 | +
- u <- ((1 / n1) + (1 / n2)) / 4+ #' ), |
|||
| 226 | -! | +|||
| 59 | +
- v <- ((1 / n1) - (1 / n2)) / 4+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
|||
| 227 | -! | +|||
| 60 | +
- V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint+ #' method = "range", |
|||
| 228 | -! | +|||
| 61 | +
- z <- stats::qchisq(p = 1 - alpha / 2, df = 1)+ #' na_str = "<Missing>" |
|||
| 229 | -! | +|||
| 62 | +
- A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint+ #' ) |
|||
| 230 | -! | +|||
| 63 | +
- B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint+ #'+ |
+ |||
| 64 | ++ |
+ #' @export+ |
+ ||
| 65 | ++ |
+ h_map_for_count_abnormal <- function(df,+ |
+ ||
| 66 | ++ |
+ variables = list(+ |
+ ||
| 67 | ++ |
+ anl = "ANRIND",+ |
+ ||
| 68 | ++ |
+ split_rows = c("PARAM"),
+ |
+ ||
| 69 | ++ |
+ range_low = "ANRLO",+ |
+ ||
| 70 | ++ |
+ range_high = "ANRHI"+ |
+ ||
| 71 | ++ |
+ ),+ |
+ ||
| 72 | ++ |
+ abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
+ |
+ ||
| 73 | ++ |
+ method = c("default", "range"),
+ |
+ ||
| 74 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+ ||
| 75 | ++ |
+ na_str = "<Missing>") {
+ |
+ ||
| 76 | +7x | +
+ if (lifecycle::is_present(na_level)) {
|
||
| 231 | +77 | ! |
- ci_lwr <- max(-1, B - A / (1 + z * u))+ lifecycle::deprecate_warn("0.9.1", "h_map_for_count_abnormal(na_level)", "h_map_for_count_abnormal(na_str)")
|
|
| 232 | +78 | ! |
- ci_upr <- min(1, B + A / (1 + z * u))+ na_str <- na_level |
|
| 233 | +79 |
- },+ } |
||
| 234 | -20x | +|||
| 80 | +
- hal = {
+
|
|||
| 235 | -1x | +81 | +7x |
- psi <- (p1_hat + p2_hat) / 2+ method <- match.arg(method) |
| 236 | -1x | +82 | +7x |
- u <- (1 / n1 + 1 / n2) / 4+ checkmate::assert_subset(c("anl", "split_rows"), names(variables))
|
| 237 | -1x | +83 | +7x |
- v <- (1 / n1 - 1 / n2) / 4+ checkmate::assert_false(anyNA(df[variables$split_rows])) |
| 238 | -1x | +84 | +7x |
- z <- kappa+ assert_df_with_variables(df, |
| 239 | -1x | +85 | +7x |
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ variables = list(anl = variables$anl, split_rows = variables$split_rows), |
| 240 | -1x | +86 | +7x |
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ na_level = na_str+ |
+
| 87 | ++ |
+ ) |
||
| 241 | -1x | +88 | +7x |
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ assert_df_with_factors(df, list(val = variables$anl)) |
| 242 | -1x | +89 | +7x |
- c(theta + w, theta - w)+ assert_valid_factor(df[[variables$anl]], any.missing = FALSE) |
| 243 | -1x | +90 | +7x |
- ci_lwr <- max(-1, theta - w)+ assert_list_of_variables(variables) |
| 244 | -1x | +91 | +7x |
- ci_upr <- min(1, theta + w)+ checkmate::assert_list(abnormal, types = "character", len = 2) |
| 245 | +92 |
- },+ |
||
| 246 | -20x | +|||
| 93 | +
- jp = {
+ # Drop usued levels from df as they are not supposed to be in the final map |
|||
| 247 | -1x | +94 | +7x |
- psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1))+ df <- droplevels(df)+ |
+
| 95 | ++ | + | ||
| 248 | -1x | +96 | +7x |
- u <- (1 / n1 + 1 / n2) / 4+ normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))+ |
+
| 97 | ++ | + + | +||
| 98 | ++ |
+ # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL" |
||
| 249 | -1x | +99 | +7x |
- v <- (1 / n1 - 1 / n2) / 4+ checkmate::assert_vector(normal_value, len = 1)+ |
+
| 100 | ++ | + + | +||
| 101 | ++ |
+ # Default method will only have what is observed in the df, and records with all normal values will be excluded to+ |
+ ||
| 102 | ++ |
+ # avoid error in layout building. |
||
| 250 | -1x | +103 | +7x |
- z <- kappa+ if (method == "default") {
|
| 251 | -1x | +104 | +3x |
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal)) |
| 252 | -1x | +105 | +3x |
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ map <- unique(df_abnormal[c(variables$split_rows, variables$anl)]) |
| 253 | -1x | +106 | +3x |
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ map_normal <- unique(subset(map, select = variables$split_rows)) |
| 254 | -1x | +107 | +3x |
- c(theta + w, theta - w)+ map_normal[[variables$anl]] <- normal_value |
| 255 | -1x | +108 | +3x |
- ci_lwr <- max(-1, theta - w)+ map <- rbind(map, map_normal) |
| 256 | -1x | +109 | +4x |
- ci_upr <- min(1, theta + w)+ } else if (method == "range") {
|
| 257 | +110 |
- },+ # range method follows the rule that at least one observation with ANRLO > 0 for low+ |
+ ||
| 111 | ++ |
+ # direction and at least one observation with ANRHI is not missing for high direction.+ |
+ ||
| 112 | +4x | +
+ checkmate::assert_subset(c("range_low", "range_high"), names(variables))
+ |
+ ||
| 113 | +4x | +
+ checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
|
||
| 258 | +114 |
- )+ |
||
| 259 | -20x | +115 | +4x |
- ci <- c(+ assert_df_with_variables(df, |
| 260 | -20x | +116 | +4x |
- est = est, lwr.ci = min(ci_lwr, ci_upr),+ variables = list( |
| 261 | -20x | +117 | +4x |
- upr.ci = max(ci_lwr, ci_upr)+ range_low = variables$range_low,+ |
+
| 118 | +4x | +
+ range_high = variables$range_high |
||
| 262 | +119 | ++ |
+ )+ |
+ |
| 120 |
) |
|||
| 263 | -20x | +|||
| 121 | +
- if (sides == "left") {
+
|
|||
| 264 | -! | +|||
| 122 | +
- ci[3] <- 1+ # Define low direction of map |
|||
| 265 | -20x | +123 | +4x |
- } else if (sides == "right") {
+ df_low <- subset(df, df[[variables$range_low]] > 0) |
| 266 | -! | +|||
| 124 | +4x |
- ci[2] <- -1+ map_low <- unique(df_low[variables$split_rows]) |
||
| 267 | -+ | |||
| 125 | +4x |
- }+ low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"])) |
||
| 268 | -20x | +126 | +4x |
- return(ci)+ low_levels_df <- as.data.frame(low_levels) |
| 269 | -+ | |||
| 127 | +4x |
- }+ colnames(low_levels_df) <- variables$anl |
||
| 270 | -20x | +128 | +4x |
- method <- match.arg(arg = method, several.ok = TRUE)+ low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
|
| 271 | -20x | +129 | +4x |
- sides <- match.arg(arg = sides, several.ok = TRUE)+ rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed |
| 272 | -20x | +130 | +4x |
- lst <- h_recycle(+ map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE] |
| 273 | -20x | +131 | +4x |
- x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level,+ map_low <- cbind(map_low, low_levels_df) |
| 274 | -20x | +|||
| 132 | +
- sides = sides, method = method+ |
|||
| 275 | +133 |
- )+ # Define high direction of map |
||
| 276 | -20x | +134 | +4x |
- res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
+ df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]])) |
| 277 | -20x | +135 | +4x |
- iBinomDiffCI(+ map_high <- unique(df_high[variables$split_rows]) |
| 278 | -20x | +136 | +4x |
- x1 = lst$x1[i],+ high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"])) |
| 279 | -20x | +137 | +4x |
- n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i],+ high_levels_df <- as.data.frame(high_levels) |
| 280 | -20x | +138 | +4x |
- sides = lst$sides[i], method = lst$method[i]+ colnames(high_levels_df) <- variables$anl |
| 281 | -+ | |||
| 139 | +4x |
- )+ high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
|
||
| 282 | -+ | |||
| 140 | +4x |
- }))+ rownames(map_high) <- NULL |
||
| 283 | -20x | +141 | +4x |
- lgn <- h_recycle(x1 = if (is.null(names(x1))) {
+ map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE] |
| 284 | -20x | +142 | +4x |
- paste("x1", seq_along(x1), sep = ".")
+ map_high <- cbind(map_high, high_levels_df) |
| 285 | +143 |
- } else {
+
|
||
| 286 | -! | +|||
| 144 | +
- names(x1)+ # Define normal of map |
|||
| 287 | -20x | +145 | +4x |
- }, n1 = if (is.null(names(n1))) {
+ map_normal <- unique(rbind(map_low, map_high)[variables$split_rows]) |
| 288 | -20x | +146 | +4x |
- paste("n1", seq_along(n1), sep = ".")
+ map_normal[variables$anl] <- normal_value |
| 289 | +147 |
- } else {
- |
- ||
| 290 | -! | -
- names(n1)+ |
||
| 291 | -20x | +148 | +4x |
- }, x2 = if (is.null(names(x2))) {
+ map <- rbind(map_low, map_high, map_normal) |
| 292 | -20x | +|||
| 149 | +
- paste("x2", seq_along(x2), sep = ".")
+ } |
|||
| 293 | +150 |
- } else {
+
|
||
| 294 | -! | +|||
| 151 | +
- names(x2)+ # map should be all characters |
|||
| 295 | -20x | +152 | +7x |
- }, n2 = if (is.null(names(n2))) {
+ map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE) |
| 296 | -20x | +|||
| 153 | +
- paste("n2", seq_along(n2), sep = ".")
+
|
|||
| 297 | +154 |
- } else {
+ # sort the map final output by split_rows variables |
||
| 298 | -! | +|||
| 155 | +7x |
- names(n2)+ for (i in rev(seq_len(length(variables$split_rows)))) {
|
||
| 299 | -20x | +156 | +7x |
- }, conf.level = conf.level, sides = sides, method = method)+ map <- map[order(map[[i]]), ] |
| 300 | -20x | +|||
| 157 | +
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ } |
|||
| 301 | -140x | +158 | +7x |
- length(unique(x)) !=+ map |
| 302 | -140x | +|||
| 159 | +
- 1+ } |
|||
| 303 | -20x | +
| 1 | +
- })]), 1, paste, collapse = ":")+ #' Create a STEP Graph |
|||
| 304 | -20x | +|||
| 2 | +
- rownames(res) <- xn+ #' |
|||
| 305 | -20x | +|||
| 3 | +
- return(res)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 306 | +4 |
- }+ #' |
||
| 307 | +5 |
-
+ #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR |
||
| 308 | +6 |
- #' @describeIn desctools_binom Compute confidence intervals for binomial proportions.+ #' along the continuous biomarker value subgroups. |
||
| 309 | +7 |
#' |
||
| 310 | +8 |
- #' @param x (`count`)\cr number of successes+ #' @param df (`tibble`)\cr result of [tidy.step()]. |
||
| 311 | +9 |
- #' @param n (`count`)\cr number of trials+ #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual |
||
| 312 | +10 |
- #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.+ #' biomarker values. |
||
| 313 | +11 |
- #' @param sides (`character`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default),+ #' @param est (named `list`)\cr `col` and `lty` settings for estimate line. |
||
| 314 | +12 |
- #' `"left"`, or `"right"`.+ #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval |
||
| 315 | +13 |
- #' @param method (`character`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`,+ #' ribbon area, or `NULL` to not plot a CI ribbon. |
||
| 316 | +14 |
- #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`,+ #' @param col (`character`)\cr colors. |
||
| 317 | +15 |
- #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`.+ #' |
||
| 318 | +16 |
- #'+ #' @return A `ggplot` STEP graph. |
||
| 319 | +17 |
- #' @return A `matrix` with 3 columns containing:+ #' |
||
| 320 | +18 |
- #' * `est`: estimate of proportion difference.+ #' @seealso Custom tidy method [tidy.step()]. |
||
| 321 | +19 |
- #' * `lwr.ci`: lower end of the confidence interval.+ #' |
||
| 322 | +20 |
- #' * `upr.ci`: upper end of the confidence interval.+ #' @examples |
||
| 323 | +21 |
- #'+ #' library(nestcolor) |
||
| 324 | +22 |
- #' @keywords internal+ #' library(survival) |
||
| 325 | +23 |
- desctools_binomci <- function(x,+ #' lung$sex <- factor(lung$sex) |
||
| 326 | +24 |
- n,+ #' |
||
| 327 | +25 |
- conf.level = 0.95, # nolint+ #' # Survival example. |
||
| 328 | +26 |
- sides = c("two.sided", "left", "right"),
+ #' vars <- list( |
||
| 329 | +27 |
- method = c(+ #' time = "time", |
||
| 330 | +28 |
- "wilson", "wald", "waldcc", "agresti-coull",+ #' event = "status", |
||
| 331 | +29 |
- "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",+ #' arm = "sex", |
||
| 332 | +30 |
- "clopper-pearson", "arcsine", "logit", "witting", "pratt",+ #' biomarker = "age" |
||
| 333 | +31 |
- "midp", "lik", "blaker"+ #' ) |
||
| 334 | +32 |
- ),+ #' |
||
| 335 | +33 |
- rand = 123,+ #' step_matrix <- fit_survival_step( |
||
| 336 | +34 |
- tol = 1e-05) {
+ #' variables = vars, |
||
| 337 | -24x | +|||
| 35 | +
- if (missing(method)) {
+ #' data = lung, |
|||
| 338 | -1x | +|||
| 36 | +
- method <- "wilson"+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
|||
| 339 | +37 |
- }+ #' ) |
||
| 340 | -24x | +|||
| 38 | +
- if (missing(sides)) {
+ #' step_data <- broom::tidy(step_matrix) |
|||
| 341 | -23x | +|||
| 39 | +
- sides <- "two.sided"+ #' |
|||
| 342 | +40 |
- }+ #' # Default plot. |
||
| 343 | -24x | +|||
| 41 | +
- iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint
+ #' g_step(step_data) |
|||
| 344 | -24x | +|||
| 42 | +
- method = c(+ #' |
|||
| 345 | -24x | +|||
| 43 | +
- "wilson", "wilsoncc", "wald",+ #' # Add the reference 1 horizontal line. |
|||
| 346 | -24x | +|||
| 44 | +
- "waldcc", "agresti-coull", "jeffreys", "modified wilson",+ #' library(ggplot2) |
|||
| 347 | -24x | +|||
| 45 | +
- "modified jeffreys", "clopper-pearson", "arcsine", "logit",+ #' g_step(step_data) + |
|||
| 348 | -24x | +|||
| 46 | +
- "witting", "pratt", "midp", "lik", "blaker"+ #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2) |
|||
| 349 | +47 |
- ),+ #' |
||
| 350 | -24x | +|||
| 48 | +
- rand = 123,+ #' # Use actual values instead of percentiles, different color for estimate and no CI, |
|||
| 351 | -24x | +|||
| 49 | +
- tol = 1e-05) {
+ #' # use log scale for y axis. |
|||
| 352 | -24x | +|||
| 50 | +
- if (length(x) != 1) {
+ #' g_step( |
|||
| 353 | -! | +|||
| 51 | +
- stop("'x' has to be of length 1 (number of successes)")
+ #' step_data, |
|||
| 354 | +52 |
- }+ #' use_percentile = FALSE, |
||
| 355 | -24x | +|||
| 53 | +
- if (length(n) != 1) {
+ #' est = list(col = "blue", lty = 1), |
|||
| 356 | -! | +|||
| 54 | +
- stop("'n' has to be of length 1 (number of trials)")
+ #' ci_ribbon = NULL |
|||
| 357 | +55 |
- }+ #' ) + scale_y_log10() |
||
| 358 | -24x | +|||
| 56 | +
- if (length(conf.level) != 1) {
+ #' |
|||
| 359 | -! | +|||
| 57 | +
- stop("'conf.level' has to be of length 1 (confidence level)")
+ #' # Adding another curve based on additional column. |
|||
| 360 | +58 |
- }+ #' step_data$extra <- exp(step_data$`Percentile Center`) |
||
| 361 | -24x | +|||
| 59 | +
- if (conf.level < 0.5 || conf.level > 1) {
+ #' g_step(step_data) + |
|||
| 362 | -! | +|||
| 60 | +
- stop("'conf.level' has to be in [0.5, 1]")
+ #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green") |
|||
| 363 | +61 |
- }+ #' |
||
| 364 | -24x | +|||
| 62 | +
- sides <- match.arg(sides, choices = c(+ #' # Response example. |
|||
| 365 | -24x | +|||
| 63 | +
- "two.sided", "left",+ #' vars <- list( |
|||
| 366 | -24x | +|||
| 64 | +
- "right"+ #' response = "status", |
|||
| 367 | -24x | +|||
| 65 | +
- ), several.ok = FALSE)+ #' arm = "sex", |
|||
| 368 | -24x | +|||
| 66 | +
- if (sides != "two.sided") {
+ #' biomarker = "age" |
|||
| 369 | -1x | +|||
| 67 | +
- conf.level <- 1 - 2 * (1 - conf.level) # nolint+ #' ) |
|||
| 370 | +68 |
- }+ #' |
||
| 371 | -24x | +|||
| 69 | +
- alpha <- 1 - conf.level+ #' step_matrix <- fit_rsp_step( |
|||
| 372 | -24x | +|||
| 70 | +
- kappa <- stats::qnorm(1 - alpha / 2)+ #' variables = vars, |
|||
| 373 | -24x | +|||
| 71 | +
- p_hat <- x / n+ #' data = lung, |
|||
| 374 | -24x | +|||
| 72 | +
- q_hat <- 1 - p_hat+ #' control = c( |
|||
| 375 | -24x | +|||
| 73 | +
- est <- p_hat+ #' control_logistic(response_definition = "I(response == 2)"), |
|||
| 376 | -24x | +|||
| 74 | +
- switch(match.arg(arg = method, choices = c(+ #' control_step() |
|||
| 377 | -24x | +|||
| 75 | +
- "wilson",+ #' ) |
|||
| 378 | -24x | +|||
| 76 | +
- "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys",+ #' ) |
|||
| 379 | -24x | +|||
| 77 | +
- "modified wilson", "modified jeffreys", "clopper-pearson",+ #' step_data <- broom::tidy(step_matrix) |
|||
| 380 | -24x | +|||
| 78 | +
- "arcsine", "logit", "witting", "pratt", "midp", "lik",+ #' g_step(step_data) |
|||
| 381 | -24x | +|||
| 79 | +
- "blaker"+ #' |
|||
| 382 | +80 |
- )),+ #' @export |
||
| 383 | -24x | +|||
| 81 | +
- wald = {
+ g_step <- function(df, |
|||
| 384 | -1x | +|||
| 82 | +
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ use_percentile = "Percentile Center" %in% names(df), |
|||
| 385 | -1x | +|||
| 83 | +
- ci_lwr <- max(0, p_hat - term2)+ est = list(col = "blue", lty = 1), |
|||
| 386 | -1x | +|||
| 84 | +
- ci_upr <- min(1, p_hat + term2)+ ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
|
|||
| 387 | +85 |
- },+ col = getOption("ggplot2.discrete.colour")) {
|
||
| 388 | -24x | +86 | +2x |
- waldcc = {
+ checkmate::assert_tibble(df) |
| 389 | -1x | +87 | +2x |
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ checkmate::assert_flag(use_percentile) |
| 390 | -1x | +88 | +2x |
- term2 <- term2 + 1 / (2 * n)+ checkmate::assert_character(col, null.ok = TRUE) |
| 391 | -1x | +89 | +2x |
- ci_lwr <- max(0, p_hat - term2)+ checkmate::assert_list(est, names = "named") |
| 392 | -1x | +90 | +2x |
- ci_upr <- min(1, p_hat + term2)+ checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE) |
| 393 | +91 |
- },- |
- ||
| 394 | -24x | -
- wilson = {
+
|
||
| 395 | -6x | +92 | +2x |
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center") |
| 396 | -6x | +93 | +2x |
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ df$x <- df[[x_var]] |
| 397 | -6x | +94 | +2x |
- ci_lwr <- max(0, term1 - term2)+ attrs <- attributes(df) |
| 398 | -6x | +95 | +2x |
- ci_upr <- min(1, term1 + term2)+ df$y <- df[[attrs$estimate]] |
| 399 | +96 |
- },- |
- ||
| 400 | -24x | -
- wilsoncc = {
+
|
||
| 401 | -3x | +|||
| 97 | +
- lci <- (+ # Set legend names. To be modified also at call level |
|||
| 402 | -3x | +98 | +2x |
- 2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1))+ legend_names <- c("Estimate", "CI 95%")
|
| 403 | -3x | +|||
| 99 | +
- ) / (2 * (n + kappa^2))+ |
|||
| 404 | -3x | +100 | +2x |
- uci <- (+ p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]])) |
| 405 | -3x | +|||
| 101 | +
- 2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1))+ |
|||
| 406 | -3x | +102 | +2x |
- ) / (2 * (n + kappa^2))+ if (!is.null(col)) {
|
| 407 | -3x | +103 | +2x |
- ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))+ p <- p + |
| 408 | -3x | +104 | +2x |
- ci_upr <- min(1, ifelse(p_hat == 1, 1, uci))+ ggplot2::scale_color_manual(values = col) |
| 409 | +105 |
- },+ } |
||
| 410 | -24x | +|||
| 106 | +
- `agresti-coull` = {
+
|
|||
| 411 | -1x | +107 | +2x |
- x_tilde <- x + kappa^2 / 2+ if (!is.null(ci_ribbon)) {
|
| 412 | +108 | 1x |
- n_tilde <- n + kappa^2+ if (is.null(ci_ribbon$fill)) {
|
|
| 413 | -1x | +|||
| 109 | +! |
- p_tilde <- x_tilde / n_tilde+ ci_ribbon$fill <- "lightblue" |
||
| 414 | -1x | +|||
| 110 | +
- q_tilde <- 1 - p_tilde+ } |
|||
| 415 | +111 | 1x |
- est <- p_tilde+ p <- p + ggplot2::geom_ribbon( |
|
| 416 | +112 | 1x |
- term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ ggplot2::aes( |
|
| 417 | +113 | 1x |
- ci_lwr <- max(0, p_tilde - term2)+ ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]], |
|
| 418 | +114 | 1x |
- ci_upr <- min(1, p_tilde + term2)+ fill = legend_names[2] |
|
| 419 | +115 |
- },- |
- ||
| 420 | -24x | -
- jeffreys = {
+ ), |
||
| 421 | +116 | 1x |
- if (x == 0) {
- |
- |
| 422 | -! | -
- ci_lwr <- 0+ alpha = ci_ribbon$alpha |
||
| 423 | +117 |
- } else {
+ ) + |
||
| 424 | +118 | 1x |
- ci_lwr <- stats::qbeta(+ scale_fill_manual( |
|
| 425 | +119 | 1x |
- alpha / 2,+ name = "", values = c("CI 95%" = ci_ribbon$fill)
|
|
| 426 | -1x | +|||
| 120 | +
- x + 0.5, n - x + 0.5+ ) |
|||
| 427 | +121 |
- )+ } |
||
| 428 | -+ | |||
| 122 | +2x |
- }+ suppressMessages(p <- p + |
||
| 429 | -1x | +123 | +2x |
- if (x == n) {
+ ggplot2::geom_line( |
| 430 | -! | +|||
| 124 | +2x |
- ci_upr <- 1+ ggplot2::aes(y = .data[["y"]], color = legend_names[1]),+ |
+ ||
| 125 | +2x | +
+ linetype = est$lty |
||
| 431 | +126 |
- } else {
+ ) + |
||
| 432 | -1x | +127 | +2x |
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)+ scale_colour_manual(+ |
+
| 128 | +2x | +
+ name = "", values = c("Estimate" = "blue")
|
||
| 433 | +129 |
- }+ )) |
||
| 434 | +130 |
- },+ |
||
| 435 | -24x | +131 | +2x |
- `modified wilson` = {
+ p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate) |
| 436 | -1x | +132 | +2x |
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ if (use_percentile) {
|
| 437 | +133 | 1x |
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ p <- p + ggplot2::scale_x_continuous(labels = scales::percent) |
|
| 438 | -1x | +|||
| 134 | +
- if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) {
+ } |
|||
| 439 | -! | +|||
| 135 | +2x |
- ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n+ p |
||
| 440 | +136 |
- } else {
+ } |
||
| 441 | -1x | +|||
| 137 | +
- ci_lwr <- max(0, term1 - term2)+ |
|||
| 442 | +138 |
- }+ #' Custom Tidy Method for STEP Results |
||
| 443 | -1x | +|||
| 139 | +
- if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) {
+ #' |
|||
| 444 | -! | +|||
| 140 | +
- ci_upr <- 1 - 0.5 * stats::qchisq(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 445 | -! | +|||
| 141 | +
- alpha,+ #' |
|||
| 446 | -! | +|||
| 142 | +
- 2 * (n - x)+ #' Tidy the STEP results into a `tibble` format ready for plotting. |
|||
| 447 | -! | +|||
| 143 | +
- ) / n+ #' |
|||
| 448 | +144 |
- } else {
+ #' @param x (`step` matrix)\cr results from [fit_survival_step()]. |
||
| 449 | -1x | +|||
| 145 | +
- ci_upr <- min(1, term1 + term2)+ #' @param ... not used here. |
|||
| 450 | +146 |
- }+ #' |
||
| 451 | +147 |
- },+ #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale, |
||
| 452 | -24x | +|||
| 148 | +
- `modified jeffreys` = {
+ #' respectively. Additional attributes carry metadata also used for plotting. |
|||
| 453 | -1x | +|||
| 149 | +
- if (x == n) {
+ #' |
|||
| 454 | -! | +|||
| 150 | +
- ci_lwr <- (alpha / 2)^(1 / n)+ #' @seealso [g_step()] which consumes the result from this function. |
|||
| 455 | +151 |
- } else {
+ #' |
||
| 456 | -1x | +|||
| 152 | +
- if (x <= 1) {
+ #' @method tidy step |
|||
| 457 | -! | +|||
| 153 | +
- ci_lwr <- 0+ #' |
|||
| 458 | +154 |
- } else {
+ #' @examples |
||
| 459 | -1x | +|||
| 155 | +
- ci_lwr <- stats::qbeta(+ #' library(survival) |
|||
| 460 | -1x | +|||
| 156 | +
- alpha / 2,+ #' lung$sex <- factor(lung$sex) |
|||
| 461 | -1x | +|||
| 157 | +
- x + 0.5, n - x + 0.5+ #' vars <- list( |
|||
| 462 | +158 |
- )+ #' time = "time", |
||
| 463 | +159 |
- }+ #' event = "status", |
||
| 464 | +160 |
- }+ #' arm = "sex", |
||
| 465 | -1x | +|||
| 161 | +
- if (x == 0) {
+ #' biomarker = "age" |
|||
| 466 | -! | +|||
| 162 | +
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ #' ) |
|||
| 467 | +163 |
- } else {
+ #' step_matrix <- fit_survival_step( |
||
| 468 | -1x | +|||
| 164 | +
- if (x >= n - 1) {
+ #' variables = vars, |
|||
| 469 | -! | +|||
| 165 | +
- ci_upr <- 1+ #' data = lung, |
|||
| 470 | +166 |
- } else {
+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
||
| 471 | -1x | +|||
| 167 | +
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)+ #' ) |
|||
| 472 | +168 |
- }+ #' broom::tidy(step_matrix) |
||
| 473 | +169 |
- }+ #' |
||
| 474 | +170 |
- },+ #' @export |
||
| 475 | -24x | +|||
| 171 | +
- `clopper-pearson` = {
+ tidy.step <- function(x, ...) { # nolint
|
|||
| 476 | -1x | +172 | +7x |
- ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1)+ checkmate::assert_class(x, "step") |
| 477 | -1x | +173 | +7x |
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x)+ dat <- as.data.frame(x) |
| 478 | -+ | |||
| 174 | +7x |
- },+ nams <- names(dat) |
||
| 479 | -24x | +175 | +7x |
- arcsine = {
+ is_surv <- "loghr" %in% names(dat) |
| 480 | -1x | +176 | +7x |
- p_tilde <- (x + 0.375) / (n + 0.75)+ est_var <- ifelse(is_surv, "loghr", "logor") |
| 481 | -1x | +177 | +7x |
- est <- p_tilde+ new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio") |
| 482 | -1x | +178 | +7x |
- ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2+ new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
|
| 483 | -1x | +179 | +7x |
- ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2+ names(dat)[match(est_var, nams)] <- new_est_var |
| 484 | -+ | |||
| 180 | +7x |
- },+ dat[, new_y_vars] <- exp(dat[, new_y_vars]) |
||
| 485 | -24x | +181 | +7x |
- logit = {
+ any_is_na <- any(is.na(dat[, new_y_vars])) |
| 486 | -1x | +182 | +7x |
- lambda_hat <- log(x / (n - x))+ any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE) |
| 487 | -1x | +183 | +7x |
- V_hat <- n / (x * (n - x)) # nolint+ if (any_is_na) {
|
| 488 | -1x | +184 | +2x |
- lambda_lower <- lambda_hat - kappa * sqrt(V_hat)+ warning(paste( |
| 489 | -1x | +185 | +2x |
- lambda_upper <- lambda_hat + kappa * sqrt(V_hat)+ "Missing values in the point estimate or CI columns,", |
| 490 | -1x | +186 | +2x |
- ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower))+ "this will lead to holes in the `g_step()` plot" |
| 491 | -1x | +|||
| 187 | +
- ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper))+ )) |
|||
| 492 | +188 |
- },+ } |
||
| 493 | -24x | +189 | +7x |
- witting = {
+ if (any_is_very_large) {
|
| 494 | -1x | +190 | +2x |
- set.seed(rand)+ warning(paste( |
| 495 | -1x | +191 | +2x |
- x_tilde <- x + stats::runif(1, min = 0, max = 1)+ "Very large absolute values in the point estimate or CI columns,", |
| 496 | -1x | +192 | +2x |
- pbinom_abscont <- function(q, size, prob) {
+ "consider adding `scale_y_log10()` to the `g_step()` result for plotting" |
| 497 | -22x | +|||
| 193 | +
- v <- trunc(q)+ )) |
|||
| 498 | -22x | +|||
| 194 | +
- term1 <- stats::pbinom(v - 1, size = size, prob = prob)+ } |
|||
| 499 | -22x | +195 | +7x |
- term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob)+ if (any_is_na || any_is_very_large) {
|
| 500 | -22x | +196 | +4x |
- return(term1 + term2)+ warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
|
| 501 | +197 |
- }+ } |
||
| 502 | -1x | +198 | +7x |
- qbinom_abscont <- function(p, size, x) {
+ structure( |
| 503 | -2x | +199 | +7x |
- fun <- function(prob, size, x, p) {
+ tibble::as_tibble(dat), |
| 504 | -22x | +200 | +7x |
- pbinom_abscont(x, size, prob) - p+ estimate = new_est_var, |
| 505 | -+ | |||
| 201 | +7x |
- }+ biomarker = attr(x, "variables")$biomarker, |
||
| 506 | -2x | +202 | +7x |
- stats::uniroot(fun,+ ci = f_conf_level(attr(x, "control")$conf_level) |
| 507 | -2x | +|||
| 203 | +
- interval = c(0, 1), size = size,+ ) |
|||
| 508 | -2x | +|||
| 204 | +
- x = x, p = p+ } |
|||
| 509 | -2x | +
| 1 | +
- )$root+ #' Confidence Intervals for a Difference of Binomials |
|||
| 510 | +2 |
- }+ #' |
||
| 511 | -1x | +|||
| 3 | +
- ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde)+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 512 | -1x | +|||
| 4 | +
- ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde)+ #' |
|||
| 513 | +5 |
- },+ #' Several confidence intervals for the difference between proportions. |
||
| 514 | -24x | +|||
| 6 | +
- pratt = {
+ #' |
|||
| 515 | -1x | +|||
| 7 | +
- if (x == 0) {
+ #' @name desctools_binom |
|||
| 516 | -! | +|||
| 8 | +
- ci_lwr <- 0+ NULL |
|||
| 517 | -! | +|||
| 9 | +
- ci_upr <- 1 - alpha^(1 / n)+ |
|||
| 518 | -1x | +|||
| 10 | +
- } else if (x == 1) {
+ #' Recycle List of Parameters |
|||
| 519 | -! | +|||
| 11 | +
- ci_lwr <- 1 - (1 - alpha / 2)^(1 / n)+ #' |
|||
| 520 | -! | +|||
| 12 | +
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ #' This function recycles all supplied elements to the maximal dimension. |
|||
| 521 | -1x | +|||
| 13 | +
- } else if (x == (n - 1)) {
+ #' |
|||
| 522 | -! | +|||
| 14 | +
- ci_lwr <- (alpha / 2)^(1 / n)+ #' @param ... (`any`)\cr Elements to recycle. |
|||
| 523 | -! | +|||
| 15 | +
- ci_upr <- (1 - alpha / 2)^(1 / n)+ #' |
|||
| 524 | -1x | +|||
| 16 | +
- } else if (x == n) {
+ #' @return A `list`. |
|||
| 525 | -! | +|||
| 17 | +
- ci_lwr <- alpha^(1 / n)+ #' |
|||
| 526 | -! | +|||
| 18 | +
- ci_upr <- 1+ #' @keywords internal |
|||
| 527 | +19 |
- } else {
+ #' @noRd |
||
| 528 | -1x | +|||
| 20 | +
- z <- stats::qnorm(1 - alpha / 2)+ h_recycle <- function(...) {
|
|||
| 529 | -1x | +21 | +64x |
- A <- ((x + 1) / (n - x))^2 # nolint+ lst <- list(...) |
| 530 | -1x | +22 | +64x |
- B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint+ maxdim <- max(lengths(lst)) |
| 531 | -1x | +23 | +64x |
- C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint+ res <- lapply(lst, rep, length.out = maxdim) |
| 532 | -1x | +24 | +64x |
- D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint+ attr(res, "maxdim") <- maxdim |
| 533 | -1x | +25 | +64x |
- E <- 1 + A * ((B + C) / D)^3 # nolint+ return(res) |
| 534 | -1x | +|||
| 26 | +
- ci_upr <- 1 / E+ } |
|||
| 535 | -1x | +|||
| 27 | +
- A <- (x / (n - x - 1))^2 # nolint+ |
|||
| 536 | -1x | +|||
| 28 | +
- B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint+ #' @describeIn desctools_binom Several confidence intervals for the difference between proportions. |
|||
| 537 | -1x | +|||
| 29 | +
- C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint+ #' |
|||
| 538 | -1x | +|||
| 30 | +
- D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint+ #' @return A `matrix` of 3 values: |
|||
| 539 | -1x | +|||
| 31 | +
- E <- 1 + A * ((B + C) / D)^3 # nolint+ #' * `est`: estimate of proportion difference. |
|||
| 540 | -1x | +|||
| 32 | +
- ci_lwr <- 1 / E+ #' * `lwr.ci`: estimate of lower end of the confidence interval. |
|||
| 541 | +33 |
- }+ #' * `upr.ci`: estimate of upper end of the confidence interval. |
||
| 542 | +34 |
- },+ #' |
||
| 543 | -24x | +|||
| 35 | +
- midp = {
+ #' @keywords internal |
|||
| 544 | -1x | +|||
| 36 | +
- f_low <- function(pi, x, n) {
+ desctools_binom <- function(x1, |
|||
| 545 | -12x | +|||
| 37 | +
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x,+ n1, |
|||
| 546 | -12x | +|||
| 38 | +
- size = n, prob = pi, lower.tail = FALSE+ x2, |
|||
| 547 | +39 |
- ) -+ n2, |
||
| 548 | -12x | +|||
| 40 | +
- (1 - conf.level) / 2+ conf.level = 0.95, # nolint |
|||
| 549 | +41 |
- }+ sides = c("two.sided", "left", "right"),
|
||
| 550 | -1x | +|||
| 42 | +
- f_up <- function(pi, x, n) {
+ method = c( |
|||
| 551 | -12x | +|||
| 43 | +
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2+ "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp" |
|||
| 552 | +44 |
- }+ )) {
|
||
| 553 | -1x | +45 | +20x |
- ci_lwr <- 0+ if (missing(sides)) {
|
| 554 | -1x | +46 | +20x |
- ci_upr <- 1+ sides <- match.arg(sides) |
| 555 | -1x | +|||
| 47 | +
- if (x != 0) {
+ } |
|||
| 556 | -1x | +48 | +20x |
- ci_lwr <- stats::uniroot(f_low,+ if (missing(method)) {
|
| 557 | +49 | 1x |
- interval = c(0, p_hat),+ method <- match.arg(method)+ |
+ |
| 50 | ++ |
+ } |
||
| 558 | -1x | +51 | +20x |
- x = x, n = n+ iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint
|
| 559 | -1x | +52 | +20x |
- )$root+ if (sides != "two.sided") {
+ |
+
| 53 | +! | +
+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
||
| 560 | +54 |
- }+ } |
||
| 561 | -1x | +55 | +20x |
- if (x != n) {
+ alpha <- 1 - conf.level |
| 562 | -1x | +56 | +20x |
- ci_upr <- stats::uniroot(f_up, interval = c(+ kappa <- stats::qnorm(1 - alpha / 2) |
| 563 | -1x | +57 | +20x |
- p_hat,+ p1_hat <- x1 / n1 |
| 564 | -1x | +58 | +20x |
- 1+ p2_hat <- x2 / n2 |
| 565 | -1x | +59 | +20x |
- ), x = x, n = n)$root+ est <- p1_hat - p2_hat |
| 566 | -+ | |||
| 60 | +20x |
- }+ switch(method, |
||
| 567 | -+ | |||
| 61 | +20x |
- },+ wald = {
|
||
| 568 | -24x | +62 | +2x |
- lik = {
+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 569 | +63 | 2x |
- ci_lwr <- 0+ term2 <- kappa * sqrt(vd) |
|
| 570 | +64 | 2x |
- ci_upr <- 1+ ci_lwr <- max(-1, est - term2) |
|
| 571 | +65 | 2x |
- z <- stats::qnorm(1 - alpha * 0.5)+ ci_upr <- min(1, est + term2)+ |
+ |
| 66 | ++ |
+ }, |
||
| 572 | -2x | +67 | +20x |
- tol <- .Machine$double.eps^0.5+ waldcc = {
|
| 573 | -2x | +68 | +4x |
- BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 574 | -+ | |||
| 69 | +4x |
- ...) {
+ term2 <- kappa * sqrt(vd) |
||
| 575 | -40x | +70 | +4x |
- ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt,+ term2 <- term2 + 0.5 * (1 / n1 + 1 / n2) |
| 576 | -40x | +71 | +4x |
- y,+ ci_lwr <- max(-1, est - term2) |
| 577 | -40x | +72 | +4x |
- log = TRUE+ ci_upr <- min(1, est + term2) |
| 578 | +73 |
- ))+ }, |
||
| 579 | -40x | +74 | +20x |
- ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x,+ ac = {
|
| 580 | -40x | +75 | +2x |
- wt, mu,+ n1 <- n1 + 2 |
| 581 | -40x | +76 | +2x |
- log = TRUE+ n2 <- n2 + 2 |
| 582 | -+ | |||
| 77 | +2x |
- ))+ x1 <- x1 + 1 |
||
| 583 | -40x | +78 | +2x |
- res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu)))+ x2 <- x2 + 1 |
| 584 | -40x | +79 | +2x |
- return(res - bound)+ p1_hat <- x1 / n1 |
| 585 | -+ | |||
| 80 | +2x |
- }+ p2_hat <- x2 / n2 |
||
| 586 | +81 | 2x |
- if (x != 0 && tol < p_hat) {
+ est1 <- p1_hat - p2_hat |
|
| 587 | +82 | 2x |
- ci_lwr <- if (BinDev(+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
|
| 588 | +83 | 2x |
- tol, x, p_hat, n, -z,+ term2 <- kappa * sqrt(vd) |
|
| 589 | +84 | 2x |
- tol+ ci_lwr <- max(-1, est1 - term2) |
|
| 590 | +85 | 2x |
- ) <= 0) {
+ ci_upr <- min(1, est1 + term2) |
|
| 591 | -2x | +|||
| 86 | +
- stats::uniroot(+ }, |
|||
| 592 | -2x | +87 | +20x |
- f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) {
+ exact = {
|
| 593 | +88 | ! |
- 1 - tol+ ci_lwr <- NA+ |
+ |
| 89 | +! | +
+ ci_upr <- NA |
||
| 594 | +90 |
- } else {
+ }, |
||
| 595 | -2x | +91 | +20x |
- p_hat+ score = {
|
| 596 | +92 | 2x |
- }), bound = -z,+ w1 <- desctools_binomci( |
|
| 597 | +93 | 2x |
- x = x, mu = p_hat, wt = n+ x = x1, n = n1, conf.level = conf.level, |
|
| 598 | +94 | 2x |
- )$root- |
- |
| 599 | -- |
- }+ method = "wilson" |
||
| 600 | +95 |
- }+ ) |
||
| 601 | +96 | 2x |
- if (x != n && p_hat < (1 - tol)) {
+ w2 <- desctools_binomci( |
|
| 602 | +97 | 2x |
- ci_upr <- if (+ x = x2, n = n2, conf.level = conf.level, |
|
| 603 | +98 | 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(+ method = "wilson" |
||
| 605 | -! | +|||
| 99 | +
- tol, x, if (p_hat < tol || p_hat == 1) {
+ ) |
|||
| 606 | -! | +|||
| 100 | +2x |
- 1 - tol+ l1 <- w1[2] |
||
| 607 | -+ | |||
| 101 | +2x |
- } else {
+ u1 <- w1[3] |
||
| 608 | -! | +|||
| 102 | +2x |
- p_hat+ l2 <- w2[2] |
||
| 609 | -! | +|||
| 103 | +2x |
- }, n,+ u2 <- w2[3] |
||
| 610 | -! | +|||
| 104 | +2x |
- -z, tol+ ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2) |
||
| 611 | -! | +|||
| 105 | +2x |
- ) <= 0) {
+ ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2) |
||
| 612 | -! | +|||
| 106 | +
- stats::uniroot(+ }, |
|||
| 613 | -! | +|||
| 107 | +20x |
- f = BinDev, interval = c(tol, p_hat),+ scorecc = {
|
||
| 614 | -! | +|||
| 108 | +1x |
- bound = -z, x = x, mu = p_hat, wt = n+ w1 <- desctools_binomci( |
||
| 615 | -! | +|||
| 109 | +1x |
- )$root+ x = x1, n = n1, conf.level = conf.level, |
||
| 616 | -+ | |||
| 110 | +1x |
- }+ method = "wilsoncc" |
||
| 617 | +111 |
- } else {
+ ) |
||
| 618 | -2x | +112 | +1x |
- stats::uniroot(+ w2 <- desctools_binomci( |
| 619 | -2x | +113 | +1x |
- f = BinDev, interval = c(if (p_hat > 1 - tol) {
+ x = x2, n = n2, conf.level = conf.level, |
| 620 | -! | +|||
| 114 | +1x |
- tol+ method = "wilsoncc" |
||
| 621 | +115 |
- } else {
+ ) |
||
| 622 | -2x | +116 | +1x |
- p_hat+ l1 <- w1[2] |
| 623 | -2x | +117 | +1x |
- }, 1 - tol), bound = z,+ u1 <- w1[3] |
| 624 | -2x | +118 | +1x |
- x = x, mu = p_hat, wt = n+ l2 <- w2[2] |
| 625 | -2x | +119 | +1x |
- )$root+ u2 <- w2[3] |
| 626 | -+ | |||
| 120 | +1x |
- }+ ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 + (u2 - p2_hat)^2)) |
||
| 627 | -+ | |||
| 121 | +1x |
- }+ ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat - l2)^2)) |
||
| 628 | +122 |
- },+ }, |
||
| 629 | -24x | +123 | +20x |
- blaker = {
+ mee = {
|
| 630 | +124 | 1x |
- acceptbin <- function(x, n, p) {
- |
- |
| 631 | -3954x | -
- p1 <- 1 - stats::pbinom(x - 1, n, p)+ .score <- function(p1, n1, p2, n2, dif) {
|
||
| 632 | -3954x | +|||
| 125 | +! |
- p2 <- stats::pbinom(x, n, p)+ if (dif > 1) dif <- 1 |
||
| 633 | -3954x | +|||
| 126 | +! |
- a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p)+ if (dif < -1) dif <- -1 |
||
| 634 | -3954x | +127 | +24x |
- a2 <- p2 + 1 - stats::pbinom(+ diff <- p1 - p2 - dif |
| 635 | -3954x | +128 | +24x |
- stats::qbinom(1 - p2, n, p), n,+ if (abs(diff) == 0) {
|
| 636 | -3954x | +|||
| 129 | +! |
- p+ res <- 0 |
||
| 637 | +130 |
- )+ } else {
|
||
| 638 | -3954x | -
- return(min(a1, a2))- |
- ||
| 639 | -+ | 131 | +24x |
- }+ t <- n2 / n1 |
| 640 | -1x | +132 | +24x |
- ci_lwr <- 0+ a <- 1 + t |
| 641 | -1x | +133 | +24x |
- ci_upr <- 1+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2)) |
| 642 | -1x | +134 | +24x |
- if (x != 0) {
+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2 |
| 643 | -1x | +135 | +24x |
- ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1)+ d <- -p1 * dif * (1 + dif) |
| 644 | -1x | +136 | +24x |
- while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) {
+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2 |
| 645 | -1976x | +137 | +24x |
- ci_lwr <- ci_lwr + tol+ if (abs(v) < .Machine$double.eps) v <- 0 |
| 646 | -+ | |||
| 138 | +24x |
- }+ s <- sqrt((b / a / 3)^2 - c / a / 3) |
||
| 647 | -+ | |||
| 139 | +24x |
- }+ u <- ifelse(v > 0, 1, -1) * s |
||
| 648 | -1x | +140 | +24x |
- if (x != n) {
+ w <- (3.141592654 + acos(v / u^3)) / 3 |
| 649 | -1x | +141 | +24x |
- ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x)+ p1d <- 2 * u * cos(w) - b / a / 3 |
| 650 | -1x | +142 | +24x |
- while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) {
+ p2d <- p1d - dif |
| 651 | -1976x | +143 | +24x |
- ci_upr <- ci_upr - tol+ n <- n1 + n2 |
| 652 | -+ | |||
| 144 | +24x |
- }+ res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) |
||
| 653 | +145 |
- }+ } |
||
| 654 | -+ | |||
| 146 | +24x |
- }+ return(sqrt(res)) |
||
| 655 | +147 |
- )+ } |
||
| 656 | -24x | +148 | +1x |
- ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min(+ pval <- function(delta) {
|
| 657 | +149 | 24x |
- 1,+ z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta) |
|
| 658 | +150 | 24x |
- ci_upr+ 2 * min(stats::pnorm(z), 1 - stats::pnorm(z)) |
|
| 659 | +151 |
- ))+ } |
||
| 660 | -24x | +152 | +1x |
- if (sides == "left") {
+ ci_lwr <- max(-1, stats::uniroot(function(delta) {
|
| 661 | -1x | +153 | +12x |
- ci[3] <- 1+ pval(delta) - alpha |
| 662 | -23x | +154 | +1x |
- } else if (sides == "right") {
+ }, interval = c(-1 + 1e-06, est - 1e-06))$root) |
| 663 | -! | +|||
| 155 | +1x |
- ci[2] <- 0+ ci_upr <- min(1, stats::uniroot(function(delta) {
|
||
| 664 | -+ | |||
| 156 | +12x |
- }+ pval(delta) - alpha |
||
| 665 | -24x | +157 | +1x |
- return(ci)+ }, interval = c(est + 1e-06, 1 - 1e-06))$root) |
| 666 | +158 |
- }+ }, |
||
| 667 | -24x | +159 | +20x |
- lst <- list(+ blj = {
|
| 668 | -24x | +160 | +1x |
- x = x, n = n, conf.level = conf.level, sides = sides,+ p1_dash <- (x1 + 0.5) / (n1 + 1) |
| 669 | -24x | +161 | +1x |
- method = method, rand = rand+ p2_dash <- (x2 + 0.5) / (n2 + 1) |
| 670 | -+ | |||
| 162 | +1x |
- )+ vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2 |
||
| 671 | -24x | +163 | +1x |
- maxdim <- max(unlist(lapply(lst, length)))+ term2 <- kappa * sqrt(vd) |
| 672 | -24x | +164 | +1x |
- lgp <- lapply(lst, rep, length.out = maxdim)+ est_dash <- p1_dash - p2_dash |
| 673 | -24x | +165 | +1x |
- lgn <- h_recycle(x = if (is.null(names(x))) {
+ ci_lwr <- max(-1, est_dash - term2) |
| 674 | -24x | +166 | +1x |
- paste("x", seq_along(x), sep = ".")
+ ci_upr <- min(1, est_dash + term2) |
| 675 | +167 |
- } else {
- |
- ||
| 676 | -! | -
- names(x)+ }, |
||
| 677 | -24x | +168 | +20x |
- }, n = if (is.null(names(n))) {
+ ha = {
|
| 678 | -24x | +169 | +4x |
- paste("n", seq_along(n), sep = ".")
+ term2 <- 1 / |
| 679 | -+ | |||
| 170 | +4x |
- } else {
+ (2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1)) |
||
| 680 | -! | +|||
| 171 | +4x |
- names(n)+ ci_lwr <- max(-1, est - term2) |
||
| 681 | -24x | +172 | +4x |
- }, conf.level = conf.level, sides = sides, method = method)+ ci_upr <- min(1, est + term2) |
| 682 | -24x | +|||
| 173 | +
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ }, |
|||
| 683 | -120x | +174 | +20x |
- length(unique(x)) !=+ mn = {
|
| 684 | -120x | +175 | +1x |
- 1+ .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
|
| 685 | -24x | +176 | +2x |
- })]), 1, paste, collapse = ":")+ p1 <- x1 / n1 |
| 686 | -24x | +177 | +2x |
- res <- t(sapply(1:maxdim, function(i) {
+ p2 <- x2 / n2 |
| 687 | -24x | +178 | +2x |
- iBinomCI(+ p_hat <- p1 - p2 |
| 688 | -24x | +179 | +2x |
- x = lgp$x[i],+ dp <- 1 + ifelse(lower, 1, -1) * p_hat |
| 689 | -24x | +180 | +2x |
- n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i],+ i <- 1 |
| 690 | -24x | +181 | +2x |
- method = lgp$method[i], rand = lgp$rand[i]+ while (i <= 50) {
|
| 691 | -+ | |||
| 182 | +46x |
- )+ dp <- 0.5 * dp |
||
| 692 | -+ | |||
| 183 | +46x |
- }))+ y <- p_hat + ifelse(lower, -1, 1) * dp |
||
| 693 | -24x | +184 | +46x |
- colnames(res)[1] <- c("est")
+ score <- .score(p1, n1, p2, n2, y) |
| 694 | -24x | +185 | +46x |
- rownames(res) <- xn+ if (score < z) {
|
| 695 | -24x | +186 | +20x |
- return(res)+ p_hat <- y |
| 696 | +187 |
- }+ } |
| 1 | -+ | |||
| 188 | +46x |
- #' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations+ if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
|
||
| 2 | -+ | |||
| 189 | +2x |
- #'+ (break)() |
||
| 3 | +190 |
- #' @description `r lifecycle::badge("stable")`
+ } else {
|
||
| 4 | -+ | |||
| 191 | +44x |
- #'+ i <- i + 1 |
||
| 5 | +192 |
- #' Helper functions that are used internally for the STEP calculations.+ } |
||
| 6 | +193 |
- #'+ } |
||
| 7 | -+ | |||
| 194 | +2x |
- #' @inheritParams argument_convention+ return(y) |
||
| 8 | +195 |
- #'+ } |
||
| 9 | -+ | |||
| 196 | +1x |
- #' @name h_step+ .score <- function(p1, n1, p2, n2, dif) {
|
||
| 10 | -+ | |||
| 197 | +46x |
- #' @include control_step.R+ diff <- p1 - p2 - dif |
||
| 11 | -+ | |||
| 198 | +46x |
- NULL+ if (abs(diff) == 0) {
|
||
| 12 | -+ | |||
| 199 | +! |
-
+ res <- 0 |
||
| 13 | +200 |
- #' @describeIn h_step creates the windows for STEP, based on the control settings+ } else {
|
||
| 14 | -+ | |||
| 201 | +46x |
- #' provided.+ t <- n2 / n1 |
||
| 15 | -+ | |||
| 202 | +46x |
- #'+ a <- 1 + t |
||
| 16 | -+ | |||
| 203 | +46x |
- #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2)) |
||
| 17 | -+ | |||
| 204 | +46x |
- #' @param control (named `list`)\cr output from `control_step()`.+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2 |
||
| 18 | -+ | |||
| 205 | +46x |
- #'+ d <- -p1 * dif * (1 + dif) |
||
| 19 | -+ | |||
| 206 | +46x |
- #' @return+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2 |
||
| 20 | -+ | |||
| 207 | +46x |
- #' * `h_step_window()` returns a list containing the window-selection matrix `sel`+ s <- sqrt((b / a / 3)^2 - c / a / 3) |
||
| 21 | -+ | |||
| 208 | +46x |
- #' and the interval information matrix `interval`.+ u <- ifelse(v > 0, 1, -1) * s |
||
| 22 | -+ | |||
| 209 | +46x |
- #'+ w <- (3.141592654 + acos(v / u^3)) / 3 |
||
| 23 | -+ | |||
| 210 | +46x |
- #' @export+ p1d <- 2 * u * cos(w) - b / a / 3 |
||
| 24 | -+ | |||
| 211 | +46x |
- h_step_window <- function(x,+ p2d <- p1d - dif |
||
| 25 | -+ | |||
| 212 | +46x |
- control = control_step()) {
+ n <- n1 + n2 |
||
| 26 | -12x | +213 | +46x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) * n / (n - 1) |
| 27 | -12x | +214 | +46x |
- checkmate::assert_list(control, names = "named")+ res <- diff^2 / var |
| 28 | +215 |
-
+ } |
||
| 29 | -12x | +216 | +46x |
- sel <- matrix(FALSE, length(x), control$num_points)+ return(res)+ |
+
| 217 | ++ |
+ } |
||
| 30 | -12x | +218 | +1x |
- out <- matrix(0, control$num_points, 3)+ z <- stats::qchisq(conf.level, 1) |
| 31 | -12x | +219 | +1x |
- colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
+ ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE)) |
| 32 | -12x | +220 | +1x |
- if (control$use_percentile) {
+ ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE)) |
| 33 | +221 |
- # Create windows according to percentile cutoffs.+ }, |
||
| 34 | -9x | +222 | +20x |
- out <- cbind(out, out)+ beal = {
|
| 35 | -9x | +|||
| 223 | +! |
- colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
+ a <- p1_hat + p2_hat |
||
| 36 | -9x | +|||
| 224 | +! |
- xs <- seq(0, 1, length = control$num_points + 2)[-1]+ b <- p1_hat - p2_hat |
||
| 37 | -9x | +|||
| 225 | +! |
- for (i in seq_len(control$num_points)) {
+ u <- ((1 / n1) + (1 / n2)) / 4 |
||
| 38 | -185x | +|||
| 226 | +! | +
+ v <- ((1 / n1) - (1 / n2)) / 4+ |
+ ||
| 227 | +! |
- out[i, 2:3] <- c(+ V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint |
||
| 39 | -185x | +|||
| 228 | +! |
- max(xs[i] - control$bandwidth, 0),+ z <- stats::qchisq(p = 1 - alpha / 2, df = 1) |
||
| 40 | -185x | +|||
| 229 | +! |
- min(xs[i] + control$bandwidth, 1)+ A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint |
||
| 41 | -+ | |||
| 230 | +! |
- )+ B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint |
||
| 42 | -185x | +|||
| 231 | +! |
- out[i, 5:6] <- stats::quantile(x, out[i, 2:3])+ ci_lwr <- max(-1, B - A / (1 + z * u)) |
||
| 43 | -185x | +|||
| 232 | +! |
- sel[, i] <- x >= out[i, 5] & x <= out[i, 6]+ ci_upr <- min(1, B + A / (1 + z * u)) |
||
| 44 | +233 |
- }+ }, |
||
| 45 | -+ | |||
| 234 | +20x |
- # Center is the middle point of the percentile window.+ hal = {
|
||
| 46 | -9x | +235 | +1x |
- out[, 1] <- xs[-control$num_points - 1]+ psi <- (p1_hat + p2_hat) / 2 |
| 47 | -9x | +236 | +1x |
- out[, 4] <- stats::quantile(x, out[, 1])+ u <- (1 / n1 + 1 / n2) / 4 |
| 48 | -+ | |||
| 237 | +1x |
- } else {
+ v <- (1 / n1 - 1 / n2) / 4 |
||
| 49 | -+ | |||
| 238 | +1x |
- # Create windows according to cutoffs.+ z <- kappa |
||
| 50 | -3x | +239 | +1x |
- m <- c(min(x), max(x))+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u) |
| 51 | -3x | +240 | +1x |
- xs <- seq(m[1], m[2], length = control$num_points + 2)[-1]+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) * |
| 52 | -3x | +241 | +1x |
- for (i in seq_len(control$num_points)) {
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint |
| 53 | -11x | +242 | +1x |
- out[i, 2:3] <- c(+ c(theta + w, theta - w) |
| 54 | -11x | +243 | +1x |
- max(xs[i] - control$bandwidth, m[1]),+ ci_lwr <- max(-1, theta - w) |
| 55 | -11x | +244 | +1x |
- min(xs[i] + control$bandwidth, m[2])+ ci_upr <- min(1, theta + w) |
| 56 | +245 |
- )+ }, |
||
| 57 | -11x | +246 | +20x |
- sel[, i] <- x >= out[i, 2] & x <= out[i, 3]+ jp = {
|
| 58 | -+ | |||
| 247 | +1x |
- }+ psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1)) |
||
| 59 | -+ | |||
| 248 | +1x |
- # Center is the same as the point for predicting.+ u <- (1 / n1 + 1 / n2) / 4 |
||
| 60 | -3x | +249 | +1x |
- out[, 1] <- xs[-control$num_points - 1]+ v <- (1 / n1 - 1 / n2) / 4 |
| 61 | -+ | |||
| 250 | +1x |
- }+ z <- kappa |
||
| 62 | -12x | +251 | +1x |
- list(sel = sel, interval = out)+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u) |
| 63 | -+ | |||
| 252 | +1x |
- }+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) * |
||
| 64 | -+ | |||
| 253 | +1x |
-
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint |
||
| 65 | -+ | |||
| 254 | +1x |
- #' @describeIn h_step calculates the estimated treatment effect estimate+ c(theta + w, theta - w) |
||
| 66 | -+ | |||
| 255 | +1x |
- #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted+ ci_lwr <- max(-1, theta - w) |
||
| 67 | -+ | |||
| 256 | +1x |
- #' on `data` given `variables` specification, for a single biomarker value `x`.+ ci_upr <- min(1, theta + w) |
||
| 68 | +257 |
- #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds+ }, |
||
| 69 | +258 |
- #' ratio estimates.+ ) |
||
| 70 | -+ | |||
| 259 | +20x |
- #'+ ci <- c( |
||
| 71 | -+ | |||
| 260 | +20x |
- #' @param model the regression model object.+ est = est, lwr.ci = min(ci_lwr, ci_upr), |
||
| 72 | -+ | |||
| 261 | +20x |
- #'+ upr.ci = max(ci_lwr, ci_upr) |
||
| 73 | +262 |
- #' @return+ ) |
||
| 74 | -+ | |||
| 263 | +20x |
- #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`.+ if (sides == "left") {
|
||
| 75 | -+ | |||
| 264 | +! |
- #'+ ci[3] <- 1 |
||
| 76 | -+ | |||
| 265 | +20x |
- #' @export+ } else if (sides == "right") {
|
||
| 77 | -+ | |||
| 266 | +! |
- h_step_trt_effect <- function(data,+ ci[2] <- -1 |
||
| 78 | +267 |
- model,+ } |
||
| 79 | -+ | |||
| 268 | +20x |
- variables,+ return(ci) |
||
| 80 | +269 |
- x) {
+ } |
||
| 81 | -208x | +270 | +20x |
- checkmate::assert_multi_class(model, c("coxph", "glm"))
+ method <- match.arg(arg = method, several.ok = TRUE) |
| 82 | -208x | +271 | +20x |
- checkmate::assert_number(x)+ sides <- match.arg(arg = sides, several.ok = TRUE) |
| 83 | -208x | +272 | +20x |
- assert_df_with_variables(data, variables)+ lst <- h_recycle( |
| 84 | -208x | -
- checkmate::assert_factor(data[[variables$arm]], n.levels = 2)- |
- ||
| 85 | -+ | 273 | +20x |
-
+ x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level, |
| 86 | -208x | +274 | +20x |
- newdata <- data[c(1, 1), ]+ sides = sides, method = method |
| 87 | -208x | +|||
| 275 | +
- newdata[, variables$biomarker] <- x+ ) |
|||
| 88 | -208x | +276 | +20x |
- newdata[, variables$arm] <- levels(data[[variables$arm]])+ res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
|
| 89 | -208x | +277 | +20x |
- model_terms <- stats::delete.response(stats::terms(model))+ iBinomDiffCI( |
| 90 | -208x | +278 | +20x |
- model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels)+ x1 = lst$x1[i], |
| 91 | -208x | +279 | +20x |
- mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts)+ n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i], |
| 92 | -208x | +280 | +20x |
- coefs <- stats::coef(model)+ sides = lst$sides[i], method = lst$method[i] |
| 93 | +281 |
- # Note: It is important to use the coef subset from matrix, otherwise intercept and+ ) |
||
| 94 | +282 |
- # strata are included for coxph() models.- |
- ||
| 95 | -208x | -
- mat <- mat[, names(coefs)]- |
- ||
| 96 | -208x | -
- mat_diff <- diff(mat)+ })) |
||
| 97 | -208x | +283 | +20x |
- est <- mat_diff %*% coefs+ lgn <- h_recycle(x1 = if (is.null(names(x1))) {
|
| 98 | -208x | +284 | +20x |
- var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff)+ paste("x1", seq_along(x1), sep = ".")
|
| 99 | -208x | +|||
| 285 | +
- se <- sqrt(var)+ } else {
|
|||
| 100 | -208x | +|||
| 286 | +! |
- c(+ names(x1) |
||
| 101 | -208x | +287 | +20x |
- est = est,+ }, n1 = if (is.null(names(n1))) {
|
| 102 | -208x | +288 | +20x |
- se = se+ paste("n1", seq_along(n1), sep = ".")
|
| 103 | +289 |
- )+ } else {
|
||
| 104 | -+ | |||
| 290 | +! |
- }+ names(n1) |
||
| 105 | -+ | |||
| 291 | +20x |
-
+ }, x2 = if (is.null(names(x2))) {
|
||
| 106 | -+ | |||
| 292 | +20x |
- #' @describeIn h_step builds the model formula used in survival STEP calculations.+ paste("x2", seq_along(x2), sep = ".")
|
||
| 107 | +293 |
- #'+ } else {
|
||
| 108 | -+ | |||
| 294 | +! |
- #' @return+ names(x2) |
||
| 109 | -+ | |||
| 295 | +20x |
- #' * `h_step_survival_formula()` returns a model formula.+ }, n2 = if (is.null(names(n2))) {
|
||
| 110 | -+ | |||
| 296 | +20x |
- #'+ paste("n2", seq_along(n2), sep = ".")
|
||
| 111 | +297 |
- #' @export+ } else {
|
||
| 112 | -+ | |||
| 298 | +! |
- h_step_survival_formula <- function(variables,+ names(n2) |
||
| 113 | -+ | |||
| 299 | +20x |
- control = control_step()) {
+ }, conf.level = conf.level, sides = sides, method = method) |
||
| 114 | -10x | +300 | +20x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
| 115 | -+ | |||
| 301 | +140x |
-
+ length(unique(x)) != |
||
| 116 | -10x | +302 | +140x |
- assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
+ 1 |
| 117 | -10x | +303 | +20x |
- form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
+ })]), 1, paste, collapse = ":") |
| 118 | -10x | +304 | +20x |
- if (control$degree > 0) {
+ rownames(res) <- xn |
| 119 | -5x | +305 | +20x |
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ return(res) |
| 120 | +306 |
- }- |
- ||
| 121 | -10x | -
- if (!is.null(variables$covariates)) {
+ } |
||
| 122 | -6x | +|||
| 307 | +
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ |
|||
| 123 | +308 |
- }+ #' @describeIn desctools_binom Compute confidence intervals for binomial proportions. |
||
| 124 | -10x | +|||
| 309 | +
- if (!is.null(variables$strata)) {
+ #' |
|||
| 125 | -2x | +|||
| 310 | +
- form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ #' @param x (`count`)\cr number of successes |
|||
| 126 | +311 |
- }+ #' @param n (`count`)\cr number of trials |
||
| 127 | -10x | +|||
| 312 | +
- stats::as.formula(form)+ #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95. |
|||
| 128 | +313 |
- }+ #' @param sides (`character`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default), |
||
| 129 | +314 |
-
+ #' `"left"`, or `"right"`. |
||
| 130 | +315 |
- #' @describeIn h_step estimates the model with `formula` built based on+ #' @param method (`character`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`, |
||
| 131 | +316 |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`, |
||
| 132 | +317 |
- #' Cox regression.+ #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`. |
||
| 133 | +318 |
#' |
||
| 134 | +319 |
- #' @param formula (`formula`)\cr the regression model formula.+ #' @return A `matrix` with 3 columns containing: |
||
| 135 | +320 |
- #' @param subset (`logical`)\cr subset vector.+ #' * `est`: estimate of proportion difference. |
||
| 136 | +321 |
- #'+ #' * `lwr.ci`: lower end of the confidence interval. |
||
| 137 | +322 |
- #' @return+ #' * `upr.ci`: upper end of the confidence interval. |
||
| 138 | +323 |
- #' * `h_step_survival_est()` returns a matrix of number of observations `n`,+ #' |
||
| 139 | +324 |
- #' `events`, log hazard ratio estimates `loghr`, standard error `se`,+ #' @keywords internal |
||
| 140 | +325 |
- #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is+ desctools_binomci <- function(x, |
||
| 141 | +326 |
- #' included for each biomarker value in `x`.+ n, |
||
| 142 | +327 |
- #'+ conf.level = 0.95, # nolint |
||
| 143 | +328 |
- #' @export+ sides = c("two.sided", "left", "right"),
|
||
| 144 | +329 |
- h_step_survival_est <- function(formula,+ method = c( |
||
| 145 | +330 |
- data,+ "wilson", "wald", "waldcc", "agresti-coull", |
||
| 146 | +331 |
- variables,+ "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys", |
||
| 147 | +332 |
- x,+ "clopper-pearson", "arcsine", "logit", "witting", "pratt", |
||
| 148 | +333 |
- subset = rep(TRUE, nrow(data)),+ "midp", "lik", "blaker" |
||
| 149 | +334 |
- control = control_coxph()) {
- |
- ||
| 150 | -55x | -
- checkmate::assert_formula(formula)+ ), |
||
| 151 | -55x | +|||
| 335 | +
- assert_df_with_variables(data, variables)+ rand = 123, |
|||
| 152 | -55x | +|||
| 336 | +
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ tol = 1e-05) {
|
|||
| 153 | -55x | +337 | +24x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ if (missing(method)) {
|
| 154 | -55x | -
- checkmate::assert_list(control, names = "named")- |
- ||
| 155 | -+ | 338 | +1x |
-
+ method <- "wilson" |
| 156 | +339 |
- # Note: `subset` in `coxph` needs to be an expression referring to `data` variables.- |
- ||
| 157 | -55x | -
- data$.subset <- subset+ } |
||
| 158 | -55x | +340 | +24x |
- coxph_warnings <- NULL+ if (missing(sides)) {
|
| 159 | -55x | +341 | +23x |
- tryCatch(+ sides <- "two.sided" |
| 160 | -55x | +|||
| 342 | +
- withCallingHandlers(+ } |
|||
| 161 | -55x | +343 | +24x |
- expr = {
+ iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint
|
| 162 | -55x | +344 | +24x |
- fit <- survival::coxph(+ method = c( |
| 163 | -55x | +345 | +24x |
- formula = formula,+ "wilson", "wilsoncc", "wald", |
| 164 | -55x | +346 | +24x |
- data = data,+ "waldcc", "agresti-coull", "jeffreys", "modified wilson", |
| 165 | -55x | +347 | +24x |
- subset = .subset,+ "modified jeffreys", "clopper-pearson", "arcsine", "logit", |
| 166 | -55x | -
- ties = control$ties- |
- ||
| 167 | -+ | 348 | +24x |
- )+ "witting", "pratt", "midp", "lik", "blaker" |
| 168 | +349 |
- },+ ), |
||
| 169 | -55x | +350 | +24x |
- warning = function(w) {
+ rand = 123, |
| 170 | -1x | +351 | +24x |
- coxph_warnings <<- c(coxph_warnings, w)+ tol = 1e-05) {
|
| 171 | -1x | +352 | +24x |
- invokeRestart("muffleWarning")
+ if (length(x) != 1) {
|
| 172 | -+ | |||
| 353 | +! |
- }+ stop("'x' has to be of length 1 (number of successes)")
|
||
| 173 | +354 |
- ),+ } |
||
| 174 | -55x | +355 | +24x |
- finally = {
+ if (length(n) != 1) {
|
| 175 | -+ | |||
| 356 | +! |
- }+ stop("'n' has to be of length 1 (number of trials)")
|
||
| 176 | +357 |
- )+ } |
||
| 177 | -55x | +358 | +24x |
- if (!is.null(coxph_warnings)) {
+ if (length(conf.level) != 1) {
|
| 178 | -1x | +|||
| 359 | +! |
- warning(paste(+ stop("'conf.level' has to be of length 1 (confidence level)")
|
||
| 179 | -1x | +|||
| 360 | +
- "Fit warnings occurred, please consider using a simpler model, or",+ } |
|||
| 180 | -1x | -
- "larger `bandwidth`, less `num_points` in `control_step()` settings"- |
- ||
| 181 | -+ | 361 | +24x |
- ))+ if (conf.level < 0.5 || conf.level > 1) {
|
| 182 | -+ | |||
| 362 | +! |
- }+ stop("'conf.level' has to be in [0.5, 1]")
|
||
| 183 | +363 |
- # Produce a matrix with one row per `x` and columns `est` and `se`.- |
- ||
| 184 | -55x | -
- estimates <- t(vapply(+ } |
||
| 185 | -55x | +364 | +24x |
- X = x,+ sides <- match.arg(sides, choices = c( |
| 186 | -55x | +365 | +24x |
- FUN = h_step_trt_effect,+ "two.sided", "left", |
| 187 | -55x | +366 | +24x |
- FUN.VALUE = c(1, 2),+ "right" |
| 188 | -55x | +367 | +24x |
- data = data,+ ), several.ok = FALSE) |
| 189 | -55x | +368 | +24x |
- model = fit,+ if (sides != "two.sided") {
|
| 190 | -55x | +369 | +1x |
- variables = variables+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
| 191 | +370 |
- ))+ } |
||
| 192 | -55x | +371 | +24x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ alpha <- 1 - conf.level |
| 193 | -55x | +372 | +24x |
- cbind(+ kappa <- stats::qnorm(1 - alpha / 2) |
| 194 | -55x | +373 | +24x |
- n = fit$n,+ p_hat <- x / n |
| 195 | -55x | +374 | +24x |
- events = fit$nevent,+ q_hat <- 1 - p_hat |
| 196 | -55x | +375 | +24x |
- loghr = estimates[, "est"],+ est <- p_hat |
| 197 | -55x | +376 | +24x |
- se = estimates[, "se"],+ switch(match.arg(arg = method, choices = c( |
| 198 | -55x | +377 | +24x |
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ "wilson", |
| 199 | -55x | -
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]- |
- ||
| 200 | -- |
- )- |
- ||
| 201 | -+ | 378 | +24x |
- }+ "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys", |
| 202 | -+ | |||
| 379 | +24x |
-
+ "modified wilson", "modified jeffreys", "clopper-pearson", |
||
| 203 | -+ | |||
| 380 | +24x |
- #' @describeIn h_step builds the model formula used in response STEP calculations.+ "arcsine", "logit", "witting", "pratt", "midp", "lik", |
||
| 204 | -+ | |||
| 381 | +24x |
- #'+ "blaker" |
||
| 205 | +382 |
- #' @return+ )), |
||
| 206 | -+ | |||
| 383 | +24x |
- #' * `h_step_rsp_formula()` returns a model formula.+ wald = {
|
||
| 207 | -+ | |||
| 384 | +1x |
- #'+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
||
| 208 | -+ | |||
| 385 | +1x |
- #' @export+ ci_lwr <- max(0, p_hat - term2) |
||
| 209 | -+ | |||
| 386 | +1x |
- h_step_rsp_formula <- function(variables,+ ci_upr <- min(1, p_hat + term2) |
||
| 210 | +387 |
- control = c(control_step(), control_logistic())) {
+ }, |
||
| 211 | -14x | +388 | +24x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ waldcc = {
|
| 212 | -14x | +389 | +1x |
- assert_list_of_variables(variables[c("arm", "biomarker", "response")])
+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
| 213 | -14x | +390 | +1x |
- response_definition <- sub(+ term2 <- term2 + 1 / (2 * n) |
| 214 | -14x | +391 | +1x |
- pattern = "response",+ ci_lwr <- max(0, p_hat - term2) |
| 215 | -14x | +392 | +1x |
- replacement = variables$response,+ ci_upr <- min(1, p_hat + term2) |
| 216 | -14x | +|||
| 393 | +
- x = control$response_definition,+ }, |
|||
| 217 | -14x | +394 | +24x |
- fixed = TRUE+ wilson = {
|
| 218 | -+ | |||
| 395 | +6x |
- )+ term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
||
| 219 | -14x | +396 | +6x |
- form <- paste0(response_definition, " ~ ", variables$arm)+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n)) |
| 220 | -14x | +397 | +6x |
- if (control$degree > 0) {
+ ci_lwr <- max(0, term1 - term2) |
| 221 | -8x | +398 | +6x |
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ ci_upr <- min(1, term1 + term2) |
| 222 | +399 |
- }+ }, |
||
| 223 | -14x | +400 | +24x |
- if (!is.null(variables$covariates)) {
+ wilsoncc = {
|
| 224 | -8x | +401 | +3x |
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ lci <- ( |
| 225 | -+ | |||
| 402 | +3x |
- }+ 2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1)) |
||
| 226 | -14x | +403 | +3x |
- if (!is.null(variables$strata)) {
+ ) / (2 * (n + kappa^2)) |
| 227 | -5x | +404 | +3x |
- strata_arg <- if (length(variables$strata) > 1) {
+ uci <- ( |
| 228 | -2x | +405 | +3x |
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ 2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1)) |
| 229 | -+ | |||
| 406 | +3x |
- } else {
+ ) / (2 * (n + kappa^2)) |
||
| 230 | +407 | 3x |
- variables$strata+ ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))+ |
+ |
| 408 | +3x | +
+ ci_upr <- min(1, ifelse(p_hat == 1, 1, uci)) |
||
| 231 | +409 |
- }+ }, |
||
| 232 | -5x | +410 | +24x |
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ `agresti-coull` = {
|
| 233 | -+ | |||
| 411 | +1x |
- }+ x_tilde <- x + kappa^2 / 2 |
||
| 234 | -14x | +412 | +1x |
- stats::as.formula(form)+ n_tilde <- n + kappa^2 |
| 235 | -+ | |||
| 413 | +1x |
- }+ p_tilde <- x_tilde / n_tilde |
||
| 236 | -+ | |||
| 414 | +1x |
-
+ q_tilde <- 1 - p_tilde |
||
| 237 | -+ | |||
| 415 | +1x |
- #' @describeIn h_step estimates the model with `formula` built based on+ est <- p_tilde |
||
| 238 | -+ | |||
| 416 | +1x |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
||
| 239 | -+ | |||
| 417 | +1x |
- #' logistic regression.+ ci_lwr <- max(0, p_tilde - term2) |
||
| 240 | -+ | |||
| 418 | +1x |
- #'+ ci_upr <- min(1, p_tilde + term2) |
||
| 241 | +419 |
- #' @param formula (`formula`)\cr the regression model formula.+ }, |
||
| 242 | -+ | |||
| 420 | +24x |
- #' @param subset (`logical`)\cr subset vector.+ jeffreys = {
|
||
| 243 | -+ | |||
| 421 | +1x |
- #'+ if (x == 0) {
|
||
| 244 | -+ | |||
| 422 | +! |
- #' @return+ ci_lwr <- 0 |
||
| 245 | +423 |
- #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds+ } else {
|
||
| 246 | -+ | |||
| 424 | +1x |
- #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds+ ci_lwr <- stats::qbeta( |
||
| 247 | -+ | |||
| 425 | +1x |
- #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`.+ alpha / 2, |
||
| 248 | -+ | |||
| 426 | +1x |
- #'+ x + 0.5, n - x + 0.5 |
||
| 249 | +427 |
- #' @export+ ) |
||
| 250 | +428 |
- h_step_rsp_est <- function(formula,+ } |
||
| 251 | -+ | |||
| 429 | +1x |
- data,+ if (x == n) {
|
||
| 252 | -+ | |||
| 430 | +! |
- variables,+ ci_upr <- 1 |
||
| 253 | +431 |
- x,+ } else {
+ |
+ ||
| 432 | +1x | +
+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
||
| 254 | +433 |
- subset = rep(TRUE, nrow(data)),+ } |
||
| 255 | +434 |
- control = control_logistic()) {
+ }, |
||
| 256 | -58x | +435 | +24x |
- checkmate::assert_formula(formula)+ `modified wilson` = {
|
| 257 | -58x | +436 | +1x |
- assert_df_with_variables(data, variables)+ term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
| 258 | -58x | +437 | +1x |
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n)) |
| 259 | -58x | +438 | +1x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) {
|
| 260 | -58x | +|||
| 439 | +! |
- checkmate::assert_list(control, names = "named")+ ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n |
||
| 261 | +440 |
- # Note: `subset` in `glm` needs to be an expression referring to `data` variables.- |
- ||
| 262 | -58x | -
- data$.subset <- subset- |
- ||
| 263 | -58x | -
- fit_warnings <- NULL+ } else {
|
||
| 264 | -58x | +441 | +1x |
- tryCatch(+ ci_lwr <- max(0, term1 - term2) |
| 265 | -58x | +|||
| 442 | +
- withCallingHandlers(+ } |
|||
| 266 | -58x | +443 | +1x |
- expr = {
+ if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) {
|
| 267 | -58x | +|||
| 444 | +! |
- fit <- if (is.null(variables$strata)) {
+ ci_upr <- 1 - 0.5 * stats::qchisq( |
||
| 268 | -54x | +|||
| 445 | +! |
- stats::glm(+ alpha, |
||
| 269 | -54x | +|||
| 446 | +! |
- formula = formula,+ 2 * (n - x) |
||
| 270 | -54x | +|||
| 447 | +! |
- data = data,+ ) / n |
||
| 271 | -54x | +|||
| 448 | +
- subset = .subset,+ } else {
|
|||
| 272 | -54x | +449 | +1x |
- family = stats::binomial("logit")
+ ci_upr <- min(1, term1 + term2) |
| 273 | +450 |
- )+ } |
||
| 274 | +451 |
- } else {
+ }, |
||
| 275 | -+ | |||
| 452 | +24x |
- # clogit needs coxph and strata imported+ `modified jeffreys` = {
|
||
| 276 | -4x | +453 | +1x |
- survival::clogit(+ if (x == n) {
|
| 277 | -4x | +|||
| 454 | +! |
- formula = formula,+ ci_lwr <- (alpha / 2)^(1 / n) |
||
| 278 | -4x | +|||
| 455 | +
- data = data,+ } else {
|
|||
| 279 | -4x | +456 | +1x |
- subset = .subset+ if (x <= 1) {
|
| 280 | -+ | |||
| 457 | +! |
- )+ ci_lwr <- 0 |
||
| 281 | +458 |
- }+ } else {
|
||
| 282 | -+ | |||
| 459 | +1x |
- },+ ci_lwr <- stats::qbeta( |
||
| 283 | -58x | +460 | +1x |
- warning = function(w) {
+ alpha / 2, |
| 284 | -19x | +461 | +1x |
- fit_warnings <<- c(fit_warnings, w)+ x + 0.5, n - x + 0.5 |
| 285 | -19x | +|||
| 462 | +
- invokeRestart("muffleWarning")
+ ) |
|||
| 286 | +463 |
- }+ } |
||
| 287 | +464 |
- ),+ } |
||
| 288 | -58x | +465 | +1x |
- finally = {
+ if (x == 0) {
|
| 289 | -+ | |||
| 466 | +! |
- }+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 290 | +467 |
- )+ } else {
|
||
| 291 | -58x | +468 | +1x |
- if (!is.null(fit_warnings)) {
+ if (x >= n - 1) {
|
| 292 | -13x | +|||
| 469 | +! |
- warning(paste(+ ci_upr <- 1 |
||
| 293 | -13x | +|||
| 470 | +
- "Fit warnings occurred, please consider using a simpler model, or",+ } else {
|
|||
| 294 | -13x | +471 | +1x |
- "larger `bandwidth`, less `num_points` in `control_step()` settings"+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
| 295 | +472 |
- ))+ } |
||
| 296 | +473 |
- }+ } |
||
| 297 | +474 |
- # Produce a matrix with one row per `x` and columns `est` and `se`.+ }, |
||
| 298 | -58x | +475 | +24x |
- estimates <- t(vapply(+ `clopper-pearson` = {
|
| 299 | -58x | +476 | +1x |
- X = x,+ ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1) |
| 300 | -58x | +477 | +1x |
- FUN = h_step_trt_effect,+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x) |
| 301 | -58x | +|||
| 478 | +
- FUN.VALUE = c(1, 2),+ }, |
|||
| 302 | -58x | +479 | +24x |
- data = data,+ arcsine = {
|
| 303 | -58x | +480 | +1x |
- model = fit,+ p_tilde <- (x + 0.375) / (n + 0.75) |
| 304 | -58x | -
- variables = variables- |
- ||
| 305 | -+ | 481 | +1x |
- ))+ est <- p_tilde |
| 306 | -58x | +482 | +1x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2 |
| 307 | -58x | +483 | +1x |
- cbind(+ ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2 |
| 308 | -58x | +|||
| 484 | +
- n = length(fit$y),+ }, |
|||
| 309 | -58x | +485 | +24x |
- logor = estimates[, "est"],+ logit = {
|
| 310 | -58x | +486 | +1x |
- se = estimates[, "se"],+ lambda_hat <- log(x / (n - x)) |
| 311 | -58x | +487 | +1x |
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ V_hat <- n / (x * (n - x)) # nolint |
| 312 | -58x | -
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]- |
- ||
| 313 | -+ | 488 | +1x |
- )+ lambda_lower <- lambda_hat - kappa * sqrt(V_hat) |
| 314 | -+ | |||
| 489 | +1x |
- }+ lambda_upper <- lambda_hat + kappa * sqrt(V_hat) |
| 1 | -+ | |||
| 490 | +1x |
- #' Bland Altman analysis+ ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower)) |
||
| 2 | -+ | |||
| 491 | +1x |
- #'+ ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper)) |
||
| 3 | +492 |
- #' @description `r lifecycle::badge("experimental")`
+ }, |
||
| 4 | -+ | |||
| 493 | +24x |
- #'+ witting = {
|
||
| 5 | -+ | |||
| 494 | +1x |
- #' Functions of bland altman method to assess the agreement between two numerical vectors.+ set.seed(rand) |
||
| 6 | -+ | |||
| 495 | +1x |
- #'+ x_tilde <- x + stats::runif(1, min = 0, max = 1) |
||
| 7 | -+ | |||
| 496 | +1x |
- #' @inheritParams argument_convention+ pbinom_abscont <- function(q, size, prob) {
|
||
| 8 | -+ | |||
| 497 | +22x |
- #' @param y ('numeric')\cr vector of numbers we want to analyze, which we want to compare with x.
+ v <- trunc(q) |
||
| 9 | -+ | |||
| 498 | +22x |
- #'+ term1 <- stats::pbinom(v - 1, size = size, prob = prob) |
||
| 10 | -+ | |||
| 499 | +22x |
- #' @name bland_altman+ term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob) |
||
| 11 | -+ | |||
| 500 | +22x |
- #' @examples+ return(term1 + term2) |
||
| 12 | +501 |
- #' x <- seq(1, 60, 5)+ } |
||
| 13 | -+ | |||
| 502 | +1x |
- #' y <- seq(5, 50, 4)+ qbinom_abscont <- function(p, size, x) {
|
||
| 14 | -+ | |||
| 503 | +2x |
- #' conf_level <- 0.9+ fun <- function(prob, size, x, p) {
|
||
| 15 | -+ | |||
| 504 | +22x |
- #' # Derive statistics that are needed for Bland Altman plot+ pbinom_abscont(x, size, prob) - p |
||
| 16 | +505 |
- #' s_bland_altman(x, y, conf_level = conf_level)+ } |
||
| 17 | -+ | |||
| 506 | +2x |
- #' # Create a Bland Altman plot+ stats::uniroot(fun, |
||
| 18 | -+ | |||
| 507 | +2x |
- #' g_bland_altman(x, y, conf_level = conf_level)+ interval = c(0, 1), size = size, |
||
| 19 | -+ | |||
| 508 | +2x |
- NULL+ x = x, p = p |
||
| 20 | -+ | |||
| 509 | +2x |
-
+ )$root |
||
| 21 | +510 |
- #' @describeIn bland_altman+ } |
||
| 22 | -+ | |||
| 511 | +1x |
- #'+ ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde) |
||
| 23 | -+ | |||
| 512 | +1x |
- #' @export+ ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde) |
||
| 24 | +513 |
- s_bland_altman <- function(x, y, conf_level = 0.95) {
+ }, |
||
| 25 | -5x | +514 | +24x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE)+ pratt = {
|
| 26 | -4x | +515 | +1x |
- checkmate::assert_numeric(y, len = length(x), any.missing = TRUE)+ if (x == 0) {
|
| 27 | -3x | +|||
| 516 | +! |
- checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE)+ ci_lwr <- 0 |
||
| 28 | -+ | |||
| 517 | +! |
-
+ ci_upr <- 1 - alpha^(1 / n) |
||
| 29 | -2x | -
- alpha <- 1 - conf_level- |
- ||
| 30 | -+ | 518 | +1x |
-
+ } else if (x == 1) {
|
| 31 | -2x | +|||
| 519 | +! |
- ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length+ ci_lwr <- 1 - (1 - alpha / 2)^(1 / n) |
||
| 32 | -2x | +|||
| 520 | +! |
- x <- x[ind]+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 33 | -2x | +521 | +1x |
- y <- y[ind]+ } else if (x == (n - 1)) {
|
| 34 | -2x | +|||
| 522 | +! |
- n <- sum(ind) # number of 'observations'+ ci_lwr <- (alpha / 2)^(1 / n) |
||
| 35 | -+ | |||
| 523 | +! |
-
+ ci_upr <- (1 - alpha / 2)^(1 / n) |
||
| 36 | -2x | +524 | +1x |
- if (n == 0) {
+ } else if (x == n) {
|
| 37 | +525 | ! |
- stop("there is no valid paired data")
+ ci_lwr <- alpha^(1 / n) |
|
| 38 | -+ | |||
| 526 | +! |
- }+ ci_upr <- 1 |
||
| 39 | +527 | - - | -||
| 40 | -2x | -
- difference <- x - y # vector of differences- |
- ||
| 41 | -2x | -
- average <- (x + y) / 2 # vector of means- |
- ||
| 42 | -2x | -
- difference_mean <- mean(difference) # mean difference+ } else {
|
||
| 43 | -2x | +528 | +1x |
- difference_sd <- sd(difference) # SD of differences+ z <- stats::qnorm(1 - alpha / 2) |
| 44 | -2x | +529 | +1x |
- al <- qnorm(1 - alpha / 2) * difference_sd+ A <- ((x + 1) / (n - x))^2 # nolint |
| 45 | -2x | +530 | +1x |
- upper_agreement_limit <- difference_mean + al # agreement limits+ B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint |
| 46 | -2x | +531 | +1x |
- lower_agreement_limit <- difference_mean - al+ C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint |
| 47 | -+ | |||
| 532 | +1x |
-
+ D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint |
||
| 48 | -+ | |||
| 533 | +1x |
-
+ E <- 1 + A * ((B + C) / D)^3 # nolint |
||
| 49 | -2x | +534 | +1x |
- difference_se <- difference_sd / sqrt(n) # standard error of the mean+ ci_upr <- 1 / E |
| 50 | -2x | +535 | +1x |
- al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit+ A <- (x / (n - x - 1))^2 # nolint |
| 51 | -2x | +536 | +1x |
- tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation+ B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint |
| 52 | -2x | +537 | +1x |
- difference_mean_ci <- difference_se * tvalue+ C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint |
| 53 | -2x | +538 | +1x |
- al_ci <- al_se * tvalue+ D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint |
| 54 | -2x | +539 | +1x |
- upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci)+ E <- 1 + A * ((B + C) / D)^3 # nolint |
| 55 | -2x | +540 | +1x |
- lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci)+ ci_lwr <- 1 / E |
| 56 | +541 |
-
+ } |
||
| 57 | +542 |
-
+ }, |
||
| 58 | -2x | +543 | +24x |
- list(+ midp = {
|
| 59 | -2x | +544 | +1x |
- df = data.frame(average, difference),+ f_low <- function(pi, x, n) {
|
| 60 | -2x | +545 | +12x |
- difference_mean = difference_mean,+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x, |
| 61 | -2x | +546 | +12x |
- ci_mean = difference_mean + c(-1, 1) * difference_mean_ci,+ size = n, prob = pi, lower.tail = FALSE |
| 62 | -2x | +|||
| 547 | +
- difference_sd = difference_sd,+ ) - |
|||
| 63 | -2x | +548 | +12x |
- difference_se = difference_se,+ (1 - conf.level) / 2 |
| 64 | -2x | +|||
| 549 | +
- upper_agreement_limit = upper_agreement_limit,+ } |
|||
| 65 | -2x | +550 | +1x |
- lower_agreement_limit = lower_agreement_limit,+ f_up <- function(pi, x, n) {
|
| 66 | -2x | +551 | +12x |
- agreement_limit_se = al_se,+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2 |
| 67 | -2x | +|||
| 552 | +
- upper_agreement_limit_ci = upper_agreement_limit_ci,+ } |
|||
| 68 | -2x | +553 | +1x |
- lower_agreement_limit_ci = lower_agreement_limit_ci,+ ci_lwr <- 0 |
| 69 | -2x | +554 | +1x |
- t_value = tvalue,+ ci_upr <- 1 |
| 70 | -2x | +555 | +1x |
- n = n+ if (x != 0) {
|
| 71 | -+ | |||
| 556 | +1x |
- )+ ci_lwr <- stats::uniroot(f_low, |
||
| 72 | -+ | |||
| 557 | +1x |
- }+ interval = c(0, p_hat), |
||
| 73 | -+ | |||
| 558 | +1x |
-
+ x = x, n = n |
||
| 74 | -+ | |||
| 559 | +1x |
- #' @describeIn bland_altman+ )$root |
||
| 75 | +560 |
- #'+ } |
||
| 76 | -+ | |||
| 561 | +1x |
- #' @export+ if (x != n) {
|
||
| 77 | -+ | |||
| 562 | +1x |
- g_bland_altman <- function(x, y, conf_level = 0.95) {
+ ci_upr <- stats::uniroot(f_up, interval = c( |
||
| 78 | -! | +|||
| 563 | +1x |
- result_tem <- s_bland_altman(x, y, conf_level = conf_level)+ p_hat, |
||
| 79 | -! | +|||
| 564 | +1x |
- xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1+ 1 |
||
| 80 | -! | +|||
| 565 | +1x |
- yrange <- diff(range(result_tem$df$difference))+ ), x = x, n = n)$root |
||
| 81 | +566 | - - | -||
| 82 | -! | -
- p <- ggplot(result_tem$df) ++ } |
||
| 83 | -! | +|||
| 567 | +
- geom_point(aes(x = average, y = difference), color = "blue") ++ }, |
|||
| 84 | -! | +|||
| 568 | +24x |
- geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) ++ lik = {
|
||
| 85 | -! | +|||
| 569 | +2x |
- geom_hline(yintercept = 0, color = "blue", linetype = 2) ++ ci_lwr <- 0 |
||
| 86 | -! | +|||
| 570 | +2x |
- geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) ++ ci_upr <- 1 |
||
| 87 | -! | +|||
| 571 | +2x |
- geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) ++ z <- stats::qnorm(1 - alpha * 0.5) |
||
| 88 | -! | +|||
| 572 | +2x |
- annotate(+ tol <- .Machine$double.eps^0.5 |
||
| 89 | -! | +|||
| 573 | +2x |
- "text",+ BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint |
||
| 90 | -! | +|||
| 574 | +
- x = xpos,+ ...) {
|
|||
| 91 | -! | +|||
| 575 | +40x |
- y = result_tem$lower_agreement_limit + 0.03 * yrange,+ ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt, |
||
| 92 | -! | +|||
| 576 | +40x |
- label = "lower limits of agreement",+ y, |
||
| 93 | -! | +|||
| 577 | +40x |
- color = "red"+ log = TRUE |
||
| 94 | +578 |
- ) ++ )) |
||
| 95 | -! | +|||
| 579 | +40x |
- annotate(+ ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x, |
||
| 96 | -! | +|||
| 580 | +40x |
- "text",+ wt, mu, |
||
| 97 | -! | +|||
| 581 | +40x |
- x = xpos,+ log = TRUE |
||
| 98 | -! | +|||
| 582 | +
- y = result_tem$upper_agreement_limit + 0.03 * yrange,+ )) |
|||
| 99 | -! | +|||
| 583 | +40x |
- label = "upper limits of agreement",+ res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu))) |
||
| 100 | -! | +|||
| 584 | +40x |
- color = "red"+ return(res - bound) |
||
| 101 | +585 |
- ) ++ } |
||
| 102 | -! | +|||
| 586 | +2x |
- annotate(+ if (x != 0 && tol < p_hat) {
|
||
| 103 | -! | +|||
| 587 | +2x |
- "text",+ ci_lwr <- if (BinDev( |
||
| 104 | -! | +|||
| 588 | +2x |
- x = xpos,+ tol, x, p_hat, n, -z, |
||
| 105 | -! | +|||
| 589 | +2x |
- y = result_tem$difference_mean + 0.03 * yrange,+ tol |
||
| 106 | -! | +|||
| 590 | +2x |
- label = "mean of difference between two measures",+ ) <= 0) {
|
||
| 107 | -! | +|||
| 591 | +2x |
- color = "blue"+ stats::uniroot( |
||
| 108 | -+ | |||
| 592 | +2x |
- ) ++ f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) {
|
||
| 109 | +593 | ! |
- annotate(+ 1 - tol |
|
| 110 | -! | +|||
| 594 | +
- "text",+ } else {
|
|||
| 111 | -! | +|||
| 595 | +2x |
- x = xpos,+ p_hat |
||
| 112 | -! | +|||
| 596 | +2x |
- y = result_tem$lower_agreement_limit - 0.03 * yrange,+ }), bound = -z, |
||
| 113 | -! | +|||
| 597 | +2x |
- label = sprintf("%.2f", result_tem$lower_agreement_limit),
+ x = x, mu = p_hat, wt = n |
||
| 114 | -! | +|||
| 598 | +2x |
- color = "red"+ )$root |
||
| 115 | +599 |
- ) ++ } |
||
| 116 | -! | +|||
| 600 | +
- annotate(+ } |
|||
| 117 | -! | +|||
| 601 | +2x |
- "text",+ if (x != n && p_hat < (1 - tol)) {
|
||
| 118 | -! | +|||
| 602 | +2x |
- x = xpos,+ 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
|
||
| 119 | +604 | ! |
- y = result_tem$upper_agreement_limit - 0.03 * yrange,+ ci_lwr <- if (BinDev( |
|
| 120 | +605 | ! |
- label = sprintf("%.2f", result_tem$upper_agreement_limit),
+ tol, x, if (p_hat < tol || p_hat == 1) {
|
|
| 121 | +606 | ! |
- color = "red"+ 1 - tol |
|
| 122 | +607 |
- ) ++ } else {
|
||
| 123 | +608 | ! |
- annotate(+ p_hat |
|
| 124 | +609 | ! |
- "text",+ }, n, |
|
| 125 | +610 | ! |
- x = xpos,+ -z, tol |
|
| 126 | +611 | ! |
- y = result_tem$difference_mean - 0.03 * yrange,+ ) <= 0) {
|
|
| 127 | +612 | ! |
- label = sprintf("%.2f", result_tem$difference_meanm),
+ stats::uniroot( |
|
| 128 | +613 | ! |
- color = "blue"- |
- |
| 129 | -- |
- ) ++ f = BinDev, interval = c(tol, p_hat), |
||
| 130 | +614 | ! |
- xlab("Average of two measures") +
+ bound = -z, x = x, mu = p_hat, wt = n |
|
| 131 | +615 | ! |
- ylab("Difference between two measures")
+ )$root |
|
| 132 | +616 | - - | -||
| 133 | -! | -
- return(p)+ } |
||
| 134 | +617 |
- }+ } else {
|
| 1 | -+ | |||
| 618 | +2x |
- #' Helper Functions for Tabulating Biomarker Effects on Survival by Subgroup+ stats::uniroot( |
||
| 2 | -+ | |||
| 619 | +2x |
- #'+ f = BinDev, interval = c(if (p_hat > 1 - tol) {
|
||
| 3 | -+ | |||
| 620 | +! |
- #' @description `r lifecycle::badge("stable")`
+ tol |
||
| 4 | +621 |
- #'+ } else {
|
||
| 5 | -+ | |||
| 622 | +2x |
- #' Helper functions which are documented here separately to not confuse the user+ p_hat |
||
| 6 | -+ | |||
| 623 | +2x |
- #' when reading about the user-facing functions.+ }, 1 - tol), bound = z, |
||
| 7 | -+ | |||
| 624 | +2x |
- #'+ x = x, mu = p_hat, wt = n |
||
| 8 | -+ | |||
| 625 | +2x |
- #' @inheritParams survival_biomarkers_subgroups+ )$root |
||
| 9 | +626 |
- #' @inheritParams argument_convention+ } |
||
| 10 | +627 |
- #' @inheritParams fit_coxreg_multivar+ } |
||
| 11 | +628 |
- #'+ }, |
||
| 12 | -+ | |||
| 629 | +24x |
- #' @examples+ blaker = {
|
||
| 13 | -+ | |||
| 630 | +1x |
- #' library(dplyr)+ acceptbin <- function(x, n, p) {
|
||
| 14 | -+ | |||
| 631 | +3954x |
- #' library(forcats)+ p1 <- 1 - stats::pbinom(x - 1, n, p) |
||
| 15 | -+ | |||
| 632 | +3954x |
- #'+ p2 <- stats::pbinom(x, n, p) |
||
| 16 | -+ | |||
| 633 | +3954x |
- #' adtte <- tern_ex_adtte+ a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p) |
||
| 17 | -+ | |||
| 634 | +3954x |
- #'+ a2 <- p2 + 1 - stats::pbinom( |
||
| 18 | -+ | |||
| 635 | +3954x |
- #' # Save variable labels before data processing steps.+ stats::qbinom(1 - p2, n, p), n, |
||
| 19 | -+ | |||
| 636 | +3954x |
- #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE)+ p |
||
| 20 | +637 |
- #'+ ) |
||
| 21 | -+ | |||
| 638 | +3954x |
- #' adtte_f <- adtte %>%+ return(min(a1, a2)) |
||
| 22 | +639 |
- #' filter(PARAMCD == "OS") %>%+ } |
||
| 23 | -+ | |||
| 640 | +1x |
- #' mutate(+ ci_lwr <- 0 |
||
| 24 | -+ | |||
| 641 | +1x |
- #' AVALU = as.character(AVALU),+ ci_upr <- 1 |
||
| 25 | -+ | |||
| 642 | +1x |
- #' is_event = CNSR == 0+ if (x != 0) {
|
||
| 26 | -+ | |||
| 643 | +1x |
- #' )+ ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1) |
||
| 27 | -+ | |||
| 644 | +1x |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) {
|
||
| 28 | -+ | |||
| 645 | +1976x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ ci_lwr <- ci_lwr + tol |
||
| 29 | +646 |
- #'+ } |
||
| 30 | +647 |
- #' @name h_survival_biomarkers_subgroups+ } |
||
| 31 | -+ | |||
| 648 | +1x |
- NULL+ if (x != n) {
|
||
| 32 | -+ | |||
| 649 | +1x |
-
+ ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x) |
||
| 33 | -+ | |||
| 650 | +1x |
- #' @describeIn h_survival_biomarkers_subgroups helps with converting the "survival" function variable list+ while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) {
|
||
| 34 | -+ | |||
| 651 | +1976x |
- #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable+ ci_upr <- ci_upr - tol |
||
| 35 | +652 |
- #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`.+ } |
||
| 36 | +653 |
- #'+ } |
||
| 37 | +654 |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ } |
||
| 38 | +655 |
- #'+ ) |
||
| 39 | -+ | |||
| 656 | +24x |
- #' @return+ ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min( |
||
| 40 | -+ | |||
| 657 | +24x |
- #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`,+ 1, |
||
| 41 | -+ | |||
| 658 | +24x |
- #' `covariates`, and `strata`.+ ci_upr |
||
| 42 | +659 |
- #'+ )) |
||
| 43 | -+ | |||
| 660 | +24x |
- #' @examples+ if (sides == "left") {
|
||
| 44 | -+ | |||
| 661 | +1x |
- #' # This is how the variable list is converted internally.+ ci[3] <- 1 |
||
| 45 | -+ | |||
| 662 | +23x |
- #' h_surv_to_coxreg_variables(+ } else if (sides == "right") {
|
||
| 46 | -+ | |||
| 663 | +! |
- #' variables = list(+ ci[2] <- 0 |
||
| 47 | +664 |
- #' tte = "AVAL",+ } |
||
| 48 | -+ | |||
| 665 | +24x |
- #' is_event = "EVNT",+ return(ci) |
||
| 49 | +666 |
- #' covariates = c("A", "B"),
+ } |
||
| 50 | -+ | |||
| 667 | +24x |
- #' strata = "D"+ lst <- list( |
||
| 51 | -+ | |||
| 668 | +24x |
- #' ),+ x = x, n = n, conf.level = conf.level, sides = sides, |
||
| 52 | -+ | |||
| 669 | +24x |
- #' biomarker = "AGE"+ method = method, rand = rand |
||
| 53 | +670 |
- #' )+ ) |
||
| 54 | -+ | |||
| 671 | +24x |
- #'+ maxdim <- max(unlist(lapply(lst, length))) |
||
| 55 | -+ | |||
| 672 | +24x |
- #' @export+ lgp <- lapply(lst, rep, length.out = maxdim) |
||
| 56 | -+ | |||
| 673 | +24x |
- h_surv_to_coxreg_variables <- function(variables, biomarker) {
+ lgn <- h_recycle(x = if (is.null(names(x))) {
|
||
| 57 | -53x | +674 | +24x |
- checkmate::assert_list(variables)+ paste("x", seq_along(x), sep = ".")
|
| 58 | -53x | +|||
| 675 | +
- checkmate::assert_string(variables$tte)+ } else {
|
|||
| 59 | -53x | +|||
| 676 | +! |
- checkmate::assert_string(variables$is_event)+ names(x) |
||
| 60 | -53x | +677 | +24x |
- checkmate::assert_string(biomarker)+ }, n = if (is.null(names(n))) {
|
| 61 | -53x | +678 | +24x |
- list(+ paste("n", seq_along(n), sep = ".")
|
| 62 | -53x | +|||
| 679 | +
- time = variables$tte,+ } else {
|
|||
| 63 | -53x | +|||
| 680 | +! |
- event = variables$is_event,+ names(n) |
||
| 64 | -53x | +681 | +24x |
- arm = biomarker,+ }, conf.level = conf.level, sides = sides, method = method) |
| 65 | -53x | +682 | +24x |
- covariates = variables$covariates,+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
| 66 | -53x | +683 | +120x |
- strata = variables$strata+ length(unique(x)) != |
| 67 | -+ | |||
| 684 | +120x |
- )+ 1 |
||
| 68 | -+ | |||
| 685 | +24x |
- }+ })]), 1, paste, collapse = ":") |
||
| 69 | -+ | |||
| 686 | +24x |
-
+ res <- t(sapply(1:maxdim, function(i) {
|
||
| 70 | -+ | |||
| 687 | +24x |
- #' @describeIn h_survival_biomarkers_subgroups prepares estimates for number of events, patients and median survival+ iBinomCI( |
||
| 71 | -+ | |||
| 688 | +24x |
- #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers+ x = lgp$x[i], |
||
| 72 | -+ | |||
| 689 | +24x |
- #' in a given single data set.+ n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i], |
||
| 73 | -+ | |||
| 690 | +24x |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ method = lgp$method[i], rand = lgp$rand[i] |
||
| 74 | +691 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strat`.+ ) |
||
| 75 | +692 |
- #'+ })) |
||
| 76 | -+ | |||
| 693 | +24x |
- #' @return+ colnames(res)[1] <- c("est")
|
||
| 77 | -+ | |||
| 694 | +24x |
- #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ rownames(res) <- xn |
||
| 78 | -+ | |||
| 695 | +24x |
- #'+ return(res) |
||
| 79 | +696 |
- #' @examples+ } |
| 80 | +1 |
- #' # For a single population, estimate separately the effects+ #' Bland Altman analysis |
||
| 81 | +2 |
- #' # of two biomarkers.+ #' |
||
| 82 | +3 |
- #' df <- h_coxreg_mult_cont_df(+ #' @description `r lifecycle::badge("experimental")`
|
||
| 83 | +4 |
- #' variables = list(+ #' |
||
| 84 | +5 |
- #' tte = "AVAL",+ #' Functions of bland altman method to assess the agreement between two numerical vectors. |
||
| 85 | +6 |
- #' is_event = "is_event",+ #' |
||
| 86 | +7 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @inheritParams argument_convention |
||
| 87 | +8 |
- #' covariates = "SEX",+ #' @param y ('numeric')\cr vector of numbers we want to analyze, which we want to compare with x.
|
||
| 88 | +9 |
- #' strata = c("STRATA1", "STRATA2")
+ #' |
||
| 89 | +10 |
- #' ),+ #' @name bland_altman |
||
| 90 | +11 |
- #' data = adtte_f+ #' @examples |
||
| 91 | +12 |
- #' )+ #' x <- seq(1, 60, 5) |
||
| 92 | +13 |
- #' df+ #' y <- seq(5, 50, 4) |
||
| 93 | +14 |
- #'+ #' conf_level <- 0.9 |
||
| 94 | +15 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ #' # Derive statistics that are needed for Bland Altman plot |
||
| 95 | +16 |
- #' h_coxreg_mult_cont_df(+ #' s_bland_altman(x, y, conf_level = conf_level) |
||
| 96 | +17 |
- #' variables = list(+ #' # Create a Bland Altman plot |
||
| 97 | +18 |
- #' tte = "AVAL",+ #' g_bland_altman(x, y, conf_level = conf_level) |
||
| 98 | +19 |
- #' is_event = "is_event",+ NULL |
||
| 99 | +20 |
- #' biomarkers = c("BMRKR1", "AGE"),
+
|
||
| 100 | +21 |
- #' covariates = "REGION1",+ #' @describeIn bland_altman |
||
| 101 | +22 |
- #' strata = c("STRATA1", "STRATA2")
+ #' |
||
| 102 | +23 |
- #' ),+ #' @export |
||
| 103 | +24 |
- #' data = adtte_f[NULL, ]+ s_bland_altman <- function(x, y, conf_level = 0.95) {
|
||
| 104 | -+ | |||
| 25 | +5x |
- #' )+ checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE) |
||
| 105 | -+ | |||
| 26 | +4x |
- #'+ checkmate::assert_numeric(y, len = length(x), any.missing = TRUE) |
||
| 106 | -+ | |||
| 27 | +3x |
- #' @export+ checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE) |
||
| 107 | +28 |
- h_coxreg_mult_cont_df <- function(variables,+ |
||
| 108 | -+ | |||
| 29 | +2x |
- data,+ alpha <- 1 - conf_level |
||
| 109 | +30 |
- control = control_coxreg()) {
- |
- ||
| 110 | -27x | -
- assert_df_with_variables(data, variables)+ |
||
| 111 | -27x | +31 | +2x |
- checkmate::assert_list(control, names = "named")+ ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length |
| 112 | -27x | +32 | +2x |
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ x <- x[ind] |
| 113 | -27x | +33 | +2x |
- conf_level <- control[["conf_level"]]+ y <- y[ind] |
| 114 | -27x | +34 | +2x |
- pval_label <- paste0(+ n <- sum(ind) # number of 'observations' |
| 115 | +35 |
- # the regex capitalizes the first letter of the string / senetence.+ |
||
| 116 | -27x | +36 | +2x |
- "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
+ if (n == 0) {
+ |
+
| 37 | +! | +
+ stop("there is no valid paired data")
|
||
| 117 | +38 |
- )+ } |
||
| 118 | +39 |
- # If there is any data, run model, otherwise return empty results.+ |
||
| 119 | -27x | +40 | +2x |
- if (nrow(data) > 0) {
+ difference <- x - y # vector of differences |
| 120 | -26x | +41 | +2x |
- bm_cols <- match(variables$biomarkers, names(data))+ average <- (x + y) / 2 # vector of means |
| 121 | -26x | +42 | +2x |
- l_result <- lapply(variables$biomarkers, function(bm) {
+ difference_mean <- mean(difference) # mean difference |
| 122 | -52x | +43 | +2x |
- coxreg_list <- fit_coxreg_multivar(+ difference_sd <- sd(difference) # SD of differences |
| 123 | -52x | +44 | +2x |
- variables = h_surv_to_coxreg_variables(variables, bm),+ al <- qnorm(1 - alpha / 2) * difference_sd |
| 124 | -52x | +45 | +2x |
- data = data,+ upper_agreement_limit <- difference_mean + al # agreement limits |
| 125 | -52x | +46 | +2x |
- control = control+ lower_agreement_limit <- difference_mean - al |
| 126 | +47 |
- )+ |
||
| 127 | -52x | +|||
| 48 | +
- result <- do.call(+ |
|||
| 128 | -52x | +49 | +2x |
- h_coxreg_multivar_extract,+ difference_se <- difference_sd / sqrt(n) # standard error of the mean |
| 129 | -52x | +50 | +2x |
- c(list(var = bm), coxreg_list[c("mod", "data", "control")])
+ al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit |
| 130 | -+ | |||
| 51 | +2x |
- )+ tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation |
||
| 131 | -52x | +52 | +2x |
- data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y))+ difference_mean_ci <- difference_se * tvalue |
| 132 | -52x | +53 | +2x |
- data_fit$status <- as.logical(data_fit$status)+ al_ci <- al_se * tvalue |
| 133 | -52x | +54 | +2x |
- median <- s_surv_time(+ upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci) |
| 134 | -52x | +55 | +2x |
- df = data_fit,+ lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci) |
| 135 | -52x | +|||
| 56 | +
- .var = "time",+ |
|||
| 136 | -52x | +|||
| 57 | +
- is_event = "status"+ |
|||
| 137 | -52x | +58 | +2x |
- )$median+ list( |
| 138 | -52x | +59 | +2x |
- data.frame(+ df = data.frame(average, difference), |
| 139 | -+ | |||
| 60 | +2x |
- # Dummy column needed downstream to create a nested header.+ difference_mean = difference_mean, |
||
| 140 | -52x | +61 | +2x |
- biomarker = bm,+ ci_mean = difference_mean + c(-1, 1) * difference_mean_ci, |
| 141 | -52x | +62 | +2x |
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ difference_sd = difference_sd, |
| 142 | -52x | +63 | +2x |
- n_tot = coxreg_list$mod$n,+ difference_se = difference_se, |
| 143 | -52x | +64 | +2x |
- n_tot_events = coxreg_list$mod$nevent,+ upper_agreement_limit = upper_agreement_limit, |
| 144 | -52x | +65 | +2x |
- median = as.numeric(median),+ lower_agreement_limit = lower_agreement_limit, |
| 145 | -52x | +66 | +2x |
- result[1L, c("hr", "lcl", "ucl")],
+ agreement_limit_se = al_se, |
| 146 | -52x | +67 | +2x |
- conf_level = conf_level,+ upper_agreement_limit_ci = upper_agreement_limit_ci, |
| 147 | -52x | +68 | +2x |
- pval = result[1L, "pval"],+ lower_agreement_limit_ci = lower_agreement_limit_ci, |
| 148 | -52x | +69 | +2x |
- pval_label = pval_label,+ t_value = tvalue, |
| 149 | -52x | +70 | +2x |
- stringsAsFactors = FALSE+ n = n |
| 150 | +71 |
- )+ ) |
||
| 151 | +72 |
- })- |
- ||
| 152 | -26x | -
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ } |
||
| 153 | +73 |
- } else {
+
|
||
| 154 | -1x | +|||
| 74 | +
- data.frame(+ #' @describeIn bland_altman |
|||
| 155 | -1x | +|||
| 75 | +
- biomarker = variables$biomarkers,+ #' |
|||
| 156 | -1x | +|||
| 76 | +
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ #' @export |
|||
| 157 | -1x | +|||
| 77 | +
- n_tot = 0L,+ g_bland_altman <- function(x, y, conf_level = 0.95) {
|
|||
| 158 | -1x | +|||
| 78 | +! |
- n_tot_events = 0L,+ result_tem <- s_bland_altman(x, y, conf_level = conf_level) |
||
| 159 | -1x | +|||
| 79 | +! |
- median = NA,+ xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1 |
||
| 160 | -1x | +|||
| 80 | +! |
- hr = NA,+ yrange <- diff(range(result_tem$df$difference)) |
||
| 161 | -1x | +|||
| 81 | +
- lcl = NA,+ |
|||
| 162 | -1x | +|||
| 82 | +! |
- ucl = NA,+ p <- ggplot(result_tem$df) + |
||
| 163 | -1x | +|||
| 83 | +! |
- conf_level = conf_level,+ geom_point(aes(x = average, y = difference), color = "blue") + |
||
| 164 | -1x | +|||
| 84 | +! |
- pval = NA,+ geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) + |
||
| 165 | -1x | +|||
| 85 | +! |
- pval_label = pval_label,+ geom_hline(yintercept = 0, color = "blue", linetype = 2) + |
||
| 166 | -1x | +|||
| 86 | +! |
- row.names = seq_along(variables$biomarkers),+ geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) + |
||
| 167 | -1x | +|||
| 87 | +! |
- stringsAsFactors = FALSE+ geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) + |
||
| 168 | -+ | |||
| 88 | +! |
- )+ annotate( |
||
| 169 | -+ | |||
| 89 | +! |
- }+ "text", |
||
| 170 | -+ | |||
| 90 | +! |
- }+ x = xpos, |
||
| 171 | -+ | |||
| 91 | +! |
-
+ y = result_tem$lower_agreement_limit + 0.03 * yrange, |
||
| 172 | -+ | |||
| 92 | +! |
- #' @describeIn h_survival_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing+ label = "lower limits of agreement", |
||
| 173 | -+ | |||
| 93 | +! |
- #' the results for a single biomarker.+ color = "red" |
||
| 174 | +94 |
- #'+ ) + |
||
| 175 | -+ | |||
| 95 | +! |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ annotate( |
||
| 176 | -+ | |||
| 96 | +! |
- #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are+ "text", |
||
| 177 | -+ | |||
| 97 | +! |
- #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],+ x = xpos, |
||
| 178 | -+ | |||
| 98 | +! |
- #' see the example).+ y = result_tem$upper_agreement_limit + 0.03 * yrange, |
||
| 179 | -+ | |||
| 99 | +! |
- #'+ label = "upper limits of agreement", |
||
| 180 | -+ | |||
| 100 | +! |
- #' @return+ color = "red" |
||
| 181 | +101 |
- #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ ) + |
||
| 182 | -+ | |||
| 102 | +! |
- #'+ annotate( |
||
| 183 | -+ | |||
| 103 | +! |
- #' @examples+ "text", |
||
| 184 | -+ | |||
| 104 | +! |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ x = xpos, |
||
| 185 | -+ | |||
| 105 | +! |
- #' df1 <- df[1, ]+ y = result_tem$difference_mean + 0.03 * yrange, |
||
| 186 | -+ | |||
| 106 | +! |
- #' df1$subgroup <- "All patients"+ label = "mean of difference between two measures", |
||
| 187 | -+ | |||
| 107 | +! |
- #' df1$row_type <- "content"+ color = "blue" |
||
| 188 | +108 |
- #' df1$var <- "ALL"+ ) + |
||
| 189 | -+ | |||
| 109 | +! |
- #' df1$var_label <- "All patients"+ annotate( |
||
| 190 | -+ | |||
| 110 | +! |
- #' h_tab_surv_one_biomarker(+ "text", |
||
| 191 | -+ | |||
| 111 | +! |
- #' df1,+ x = xpos, |
||
| 192 | -+ | |||
| 112 | +! |
- #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ y = result_tem$lower_agreement_limit - 0.03 * yrange, |
||
| 193 | -+ | |||
| 113 | +! |
- #' time_unit = "days"+ label = sprintf("%.2f", result_tem$lower_agreement_limit),
|
||
| 194 | -+ | |||
| 114 | +! |
- #' )+ color = "red" |
||
| 195 | +115 |
- #'+ ) + |
||
| 196 | -+ | |||
| 116 | +! |
- #' @export+ annotate( |
||
| 197 | -+ | |||
| 117 | +! |
- h_tab_surv_one_biomarker <- function(df,+ "text", |
||
| 198 | -+ | |||
| 118 | +! |
- vars,+ x = xpos, |
||
| 199 | -+ | |||
| 119 | +! |
- time_unit,+ y = result_tem$upper_agreement_limit - 0.03 * yrange, |
||
| 200 | -+ | |||
| 120 | +! |
- na_str = default_na_str(),+ label = sprintf("%.2f", result_tem$upper_agreement_limit),
|
||
| 201 | -+ | |||
| 121 | +! |
- .indent_mods = 0L,+ color = "red" |
||
| 202 | +122 |
- ...) {
+ ) + |
||
| 203 | -8x | +|||
| 123 | +! |
- afuns <- a_survival_subgroups(na_str = na_str)[vars]+ annotate( |
||
| 204 | -8x | +|||
| 124 | +! |
- colvars <- d_survival_subgroups_colvars(+ "text", |
||
| 205 | -8x | +|||
| 125 | +! |
- vars,+ x = xpos, |
||
| 206 | -8x | +|||
| 126 | +! |
- conf_level = df$conf_level[1],+ y = result_tem$difference_mean - 0.03 * yrange, |
||
| 207 | -8x | +|||
| 127 | +! |
- method = df$pval_label[1],+ label = sprintf("%.2f", result_tem$difference_meanm),
|
||
| 208 | -8x | +|||
| 128 | +! |
- time_unit = time_unit+ color = "blue" |
||
| 209 | +129 |
- )- |
- ||
| 210 | -8x | -
- h_tab_one_biomarker(- |
- ||
| 211 | -8x | -
- df = df,- |
- ||
| 212 | -8x | -
- afuns = afuns,- |
- ||
| 213 | -8x | -
- colvars = colvars,+ ) + |
||
| 214 | -8x | +|||
| 130 | +! |
- na_str = na_str,+ xlab("Average of two measures") +
|
||
| 215 | -8x | +|||
| 131 | +! |
- .indent_mods = .indent_mods,+ ylab("Difference between two measures")
|
||
| 216 | +132 |
- ...+ |
||
| 217 | -+ | |||
| 133 | +! |
- )+ return(p) |
||
| 218 | +134 |
}@@ -75344,10814 +77070,9858 @@ tern coverage - 90.46% |
||
| 679 | -- |
- table_names = vars,- |
- ||
| 680 | -- |
- section_div = NA_character_,- |
- ||
| 681 | -- |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
- |
- ||
| 682 | -- |
- .formats = NULL,- |
- ||
| 683 | -- |
- .labels = NULL,- |
- ||
| 684 | -- |
- .indent_mods = NULL) {
- |
- ||
| 685 | -27x | -
- if (lifecycle::is_present(na_level)) {
- |
- ||
| 686 | -! | -
- lifecycle::deprecate_warn("0.9.1", "analyze_vars(na_level)", "analyze_vars(na_str)")
- |
- ||
| 687 | -! | -
- na_str <- na_level- |
- ||
| 688 | -- |
- }- |
- ||
| 689 | -- | - - | -||
| 690 | -27x | -
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...)- |
- ||
| 691 | -3x | -
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats- |
- ||
| 692 | -! | -
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels- |
- ||
| 693 | -! | -
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods- |
- ||
| 694 | -- | - - | -||
| 695 | -27x | -
- analyze(- |
- ||
| 696 | -27x | -
- lyt = lyt,- |
- ||
| 697 | -27x | -
- vars = vars,- |
- ||
| 698 | -27x | -
- var_labels = var_labels,- |
- ||
| 699 | -27x | -
- afun = a_summary,- |
- ||
| 700 | -27x | -
- na_str = na_str,- |
- ||
| 701 | -27x | -
- nested = nested,- |
- ||
| 702 | -27x | -
- extra_args = extra_args,- |
- ||
| 703 | -27x | -
- inclNAs = TRUE,- |
- ||
| 704 | -27x | -
- show_labels = show_labels,- |
- ||
| 705 | -27x | -
- table_names = table_names,- |
- ||
| 706 | -27x | -
- section_div = section_div- |
- ||
| 707 | -- |
- )- |
- ||
| 708 | -- |
- }- |
- ||
| 709 | -- |
- #' @describeIn analyze_variables `r lifecycle::badge("deprecated")` Use `analyze_vars` instead.
- |
- ||
| 710 | -- |
- summarize_vars <- function(...) {
- |
- ||
| 711 | -! | -
- lifecycle::deprecate_warn(when = "0.8.5.9010", "summarize_vars()", "analyze_vars()")- |
- ||
| 712 | -! | -
- analyze_vars(...)- |
- ||
| 713 | -- |
- }- |
-
| 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 grid::gTree- |
- |
| 10 | -- |
- #' @inheritParams argument_convention- |
- |
| 11 | -- |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.- |
- |
| 12 | -- |
- #' @param variables (named `list`)\cr variable names. Details are:- |
- |
| 13 | -- |
- #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values.- |
- |
| 14 | -- |
- #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.- |
- |
| 15 | -- |
- #' * `arm` (`factor`)\cr the treatment group variable.- |
- |
| 16 | -- |
- #' * `strat` (`character` or `NULL`)\cr variable names indicating stratification factors.- |
- |
| 17 | -- |
- #' @param control_surv (`list`)\cr parameters for comparison details, specified by using- |
- |
| 18 | -- |
- #' the helper function [control_surv_timepoint()]. Some possible parameter options are:- |
- |
| 19 | -- |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.- |
- |
| 20 | -- |
- #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type,- |
- |
| 21 | -- |
- #' see more in [survival::survfit()]. Note that the option "none" is no longer supported.- |
- |
| 22 | -- |
- #' @param xticks (`numeric`, `number`, or `NULL`)\cr numeric vector of ticks or single number with spacing- |
- |
| 23 | -- |
- #' between ticks on the x axis. If `NULL` (default), [labeling::extended()] is used to determine- |
- |
| 24 | -- |
- #' an optimal tick position on the x axis.- |
- |
| 25 | -- |
- #' @param yval (`string`)\cr value of y-axis. Options are `Survival` (default) and `Failure` probability.- |
- |
| 26 | -- |
- #' @param censor_show (`flag`)\cr whether to show censored.- |
- |
| 27 | -- |
- #' @param xlab (`string`)\cr label of x-axis.- |
- |
| 28 | -- |
- #' @param ylab (`string`)\cr label of y-axis.- |
- |
| 29 | -- |
- #' @param ylim (`vector` of `numeric`)\cr vector of length 2 containing lower and upper limits for the y-axis.- |
- |
| 30 | -- |
- #' If `NULL` (default), the minimum and maximum y-values displayed are used as limits.- |
- |
| 31 | -- |
- #' @param title (`string`)\cr title for plot.- |
- |
| 32 | -- |
- #' @param footnotes (`string`)\cr footnotes for plot.- |
- |
| 33 | -- |
- #' @param col (`character`)\cr lines colors. Length of a vector should be equal- |
- |
| 34 | -- |
- #' to number of strata from [survival::survfit()].- |
- |
| 35 | -- |
- #' @param lty (`numeric`)\cr line type. Length of a vector should be equal- |
- |
| 36 | -- |
- #' to number of strata from [survival::survfit()].- |
- |
| 37 | -- |
- #' @param lwd (`numeric`)\cr line width. Length of a vector should be equal- |
- |
| 38 | -- |
- #' to number of strata from [survival::survfit()].- |
- |
| 39 | -- |
- #' @param pch (`numeric`, `string`)\cr value or character of points symbol to indicate censored cases.- |
- |
| 40 | -- |
- #' @param size (`numeric`)\cr size of censored point, a class of `unit`.- |
- |
| 41 | -- |
- #' @param max_time (`numeric`)\cr maximum value to show on X axis. Only data values less than or up to- |
- |
| 42 | -- |
- #' this threshold value will be plotted (defaults to `NULL`).- |
- |
| 43 | -- |
- #' @param font_size (`number`)\cr font size to be used.- |
- |
| 44 | -- |
- #' @param ci_ribbon (`flag`)\cr draw the confidence interval around the Kaplan-Meier curve.- |
- |
| 45 | -- |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control outlook of the Kaplan-Meier curve.- |
- |
| 46 | -- |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk- |
- |
| 47 | -- |
- #' matching the main grid of the Kaplan-Meier curve.- |
- |
| 48 | -- |
- #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`- |
- |
| 49 | -- |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.- |
- |
| 50 | -- |
- #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the- |
- |
| 51 | -- |
- #' median survival time per group.- |
- |
| 52 | -- |
- #' @param annot_coxph (`flag`)\cr add the annotation table from a [survival::coxph()] model.- |
- |
| 53 | -- |
- #' @param annot_stats (`string`)\cr statistics annotations to add to the plot. Options are- |
- |
| 54 | -- |
- #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time).- |
- |
| 55 | -- |
- #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics- |
- |
| 56 | -- |
- #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.- |
- |
| 57 | -- |
- #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified by using- |
- |
| 58 | -- |
- #' the helper function [control_coxph()]. Some possible parameter options are:- |
- |
| 59 | -- |
- #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.- |
- |
| 60 | -- |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.- |
- |
| 61 | -- |
- #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`,- |
- |
| 62 | -- |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]- |
- |
| 63 | -- |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.- |
- |
| 64 | -- |
- #' @param ref_group_coxph (`character`)\cr level of arm variable to use as reference group in calculations for- |
- |
| 65 | -- |
- #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable.- |
- |
| 66 | -- |
- #' @param annot_coxph_ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the- |
- |
| 67 | -- |
- #' `annot_coxph` table. If `FALSE` (default), only comparison groups will be printed in `annot_coxph` table labels.- |
- |
| 68 | -- |
- #' @param position_coxph (`numeric`)\cr x and y positions for plotting [survival::coxph()] model.- |
- |
| 69 | -- |
- #' @param position_surv_med (`numeric`)\cr x and y positions for plotting annotation table estimating median survival- |
- |
| 70 | -- |
- #' time per group.- |
- |
| 71 | -- |
- #' @param width_annots (named `list` of `unit`s)\cr a named list of widths for annotation tables with names `surv_med`- |
- |
| 72 | -- |
- #' (median survival time table) and `coxph` ([survival::coxph()] model table), where each value is the width- |
- |
| 73 | -- |
- #' (in units) to implement when printing the annotation table.- |
- |
| 74 | -- |
- #'- |
- |
| 75 | -- |
- #' @return A `grob` of class `gTree`.- |
- |
| 76 | -- |
- #'- |
- |
| 77 | -- |
- #' @examples- |
- |
| 78 | -- |
- #' \donttest{
- |
- |
| 79 | -- |
- #' library(dplyr)- |
- |
| 80 | -- |
- #' library(ggplot2)- |
- |
| 81 | -- |
- #' library(survival)- |
- |
| 82 | -- |
- #' library(grid)- |
- |
| 83 | -- |
- #' library(nestcolor)- |
- |
| 84 | -- |
- #'- |
- |
| 85 | -- |
- #' df <- tern_ex_adtte %>%- |
- |
| 86 | -- |
- #' filter(PARAMCD == "OS") %>%- |
- |
| 87 | -- |
- #' mutate(is_event = CNSR == 0)- |
- |
| 88 | -- |
- #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")- |
- |
| 89 | -- |
- #'- |
- |
| 90 | -- |
- #' # 1. Example - basic option- |
- |
| 91 | -- |
- #'- |
- |
| 92 | -- |
- #' res <- g_km(df = df, variables = variables)- |
- |
| 93 | -- |
- #' res <- g_km(df = df, variables = variables, yval = "Failure")- |
- |
| 94 | -- |
- #' res <- g_km(- |
- |
| 95 | -- |
- #' df = df,- |
- |
| 96 | -- |
- #' variables = variables,- |
- |
| 97 | -- |
- #' control_surv = control_surv_timepoint(conf_level = 0.9),- |
- |
| 98 | -- |
- #' col = c("grey25", "grey50", "grey75"),
- |
- |
| 99 | -- |
- #' annot_at_risk_title = FALSE- |
- |
| 100 | -- |
- #' )- |
- |
| 101 | -- |
- #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal())- |
- |
| 102 | -- |
- #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal(), lty = 1:3)- |
- |
| 103 | -- |
- #' res <- g_km(df = df, variables = variables, max = 2000)- |
- |
| 104 | -- |
- #' res <- g_km(- |
- |
| 105 | -- |
- #' df = df,- |
- |
| 106 | -- |
- #' variables = variables,- |
- |
| 107 | -- |
- #' annot_stats = c("min", "median"),
- |
- |
| 108 | -- |
- #' annot_stats_vlines = TRUE- |
- |
| 109 | +679 |
- #' )+ table_names = vars, |
|
| 110 | +680 |
- #'+ section_div = NA_character_, |
|
| 111 | +681 |
- #' # 2. Example - Arrange several KM curve on a single graph device+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
|
| 112 | +682 |
- #'+ .formats = NULL, |
|
| 113 | +683 |
- #' # 2.1 Use case: A general graph on the top, a zoom on the bottom.+ .labels = NULL, |
|
| 114 | +684 |
- #' grid.newpage()+ .indent_mods = NULL) {
|
|
| 115 | -+ | ||
| 685 | +27x |
- #' lyt <- grid.layout(nrow = 2, ncol = 1) %>%+ if (lifecycle::is_present(na_level)) {
|
|
| 116 | -+ | ||
| 686 | +! |
- #' viewport(layout = .) %>%+ lifecycle::deprecate_warn("0.9.1", "analyze_vars(na_level)", "analyze_vars(na_str)")
|
|
| 117 | -+ | ||
| 687 | +! |
- #' pushViewport()+ na_str <- na_level |
|
| 118 | +688 |
- #'+ } |
|
| 119 | +689 |
- #' res <- g_km(+ |
|
| 120 | -+ | ||
| 690 | +27x |
- #' df = df, variables = variables, newpage = FALSE, annot_surv_med = FALSE,+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...) |
|
| 121 | -+ | ||
| 691 | +3x |
- #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1)+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
|
| 122 | -+ | ||
| 692 | +! |
- #' )+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
|
| 123 | -+ | ||
| 693 | +! |
- #' res <- g_km(+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
|
| 124 | +694 |
- #' df = df, variables = variables, max = 1000, newpage = FALSE, annot_surv_med = FALSE,+ |
|
| 125 | -+ | ||
| 695 | +27x |
- #' ggtheme = theme_dark(),+ analyze( |
|
| 126 | -+ | ||
| 696 | +27x |
- #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1)+ lyt = lyt, |
|
| 127 | -+ | ||
| 697 | +27x |
- #' )+ vars = vars, |
|
| 128 | -+ | ||
| 698 | +27x |
- #'+ var_labels = var_labels, |
|
| 129 | -+ | ||
| 699 | +27x |
- #' # 2.1 Use case: No annotations on top, annotated graph on bottom+ afun = a_summary, |
|
| 130 | -+ | ||
| 700 | +27x |
- #' grid.newpage()+ na_str = na_str, |
|
| 131 | -+ | ||
| 701 | +27x |
- #' lyt <- grid.layout(nrow = 2, ncol = 1) %>%+ nested = nested, |
|
| 132 | -+ | ||
| 702 | +27x |
- #' viewport(layout = .) %>%+ extra_args = extra_args, |
|
| 133 | -+ | ||
| 703 | +27x |
- #' pushViewport()+ inclNAs = TRUE, |
|
| 134 | -+ | ||
| 704 | +27x |
- #'+ show_labels = show_labels, |
|
| 135 | -+ | ||
| 705 | +27x |
- #' res <- g_km(+ table_names = table_names, |
|
| 136 | -+ | ||
| 706 | +27x |
- #' df = df, variables = variables, newpage = FALSE,+ section_div = section_div |
|
| 137 | +707 |
- #' annot_surv_med = FALSE, annot_at_risk = FALSE,+ ) |
|
| 138 | +708 |
- #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1)+ } |
|
| 139 | +709 |
- #' )+ #' @describeIn analyze_variables `r lifecycle::badge("deprecated")` Use `analyze_vars` instead.
|
|
| 140 | +710 |
- #' res <- g_km(+ summarize_vars <- function(...) {
|
|
| 141 | -+ | ||
| 711 | +! |
- #' df = df, variables = variables, max = 2000, newpage = FALSE, annot_surv_med = FALSE,+ lifecycle::deprecate_warn(when = "0.8.5.9010", "summarize_vars()", "analyze_vars()")+ |
+ |
| 712 | +! | +
+ analyze_vars(...) |
|
| 142 | +713 |
- #' annot_at_risk = TRUE,+ } |
| 143 | +1 |
- #' ggtheme = theme_dark(),+ # Utility functions to cooperate with {rtables} package
|
||
| 144 | +2 |
- #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1)+ |
||
| 145 | +3 |
- #' )+ #' Convert Table into Matrix of Strings |
||
| 146 | +4 |
#' |
||
| 147 | +5 |
- #' # Add annotation from a pairwise coxph analysis+ #' @description `r lifecycle::badge("stable")`
|
||
| 148 | +6 |
- #' g_km(+ #' |
||
| 149 | +7 |
- #' df = df, variables = variables,+ #' Helper function to use mostly within tests. `with_spaces`parameter allows |
||
| 150 | +8 |
- #' annot_coxph = TRUE+ #' to test not only for content but also indentation and table structure. |
||
| 151 | +9 |
- #' )+ #' `print_txt_to_copy` instead facilitate the testing development by returning a well |
||
| 152 | +10 |
- #'+ #' formatted text that needs only to be copied and pasted in the expected output. |
||
| 153 | +11 |
- #' # Change widths/sizes of surv_med and coxph annotation tables.+ #' |
||
| 154 | +12 |
- #' g_km(+ #' @inheritParams formatters::toString |
||
| 155 | +13 |
- #' df = df, variables = c(variables, list(strat = "SEX")),+ #' @param x `rtables` table. |
||
| 156 | +14 |
- #' annot_coxph = TRUE,+ #' @param with_spaces (`logical`)\cr should the tested table keep the indentation and other relevant spaces? |
||
| 157 | +15 |
- #' width_annots = list(surv_med = grid::unit(2, "in"), coxph = grid::unit(3, "in"))+ #' @param print_txt_to_copy (`logical`)\cr utility to have a way to copy the input table directly |
||
| 158 | +16 |
- #' )+ #' into the expected variable instead of copying it too manually. |
||
| 159 | +17 |
#' |
||
| 160 | +18 |
- #' g_km(+ #' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the |
||
| 161 | +19 |
- #' df = df, variables = c(variables, list(strat = "SEX")),+ #' table will be printed to console, ready to be copied as a expected value. |
||
| 162 | +20 |
- #' font_size = 15,+ #' |
||
| 163 | +21 |
- #' annot_coxph = TRUE,+ #' @examples |
||
| 164 | +22 |
- #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ #' tbl <- basic_table() %>% |
||
| 165 | +23 |
- #' position_coxph = c(0.5, 0.5)+ #' split_rows_by("SEX") %>%
|
||
| 166 | +24 |
- #' )+ #' split_cols_by("ARM") %>%
|
||
| 167 | +25 |
- #'+ #' analyze("AGE") %>%
|
||
| 168 | +26 |
- #' # Change position of the treatment group annotation table.+ #' build_table(tern_ex_adsl) |
||
| 169 | +27 |
- #' g_km(+ #' |
||
| 170 | +28 |
- #' df = df, variables = c(variables, list(strat = "SEX")),+ #' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2)) |
||
| 171 | +29 |
- #' font_size = 15,+ #' |
||
| 172 | +30 |
- #' annot_coxph = TRUE,+ #' @export |
||
| 173 | +31 |
- #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ to_string_matrix <- function(x, widths = NULL, max_width = NULL, |
||
| 174 | +32 |
- #' position_surv_med = c(1, 0.7)+ hsep = formatters::default_hsep(), |
||
| 175 | +33 |
- #' )+ with_spaces = TRUE, print_txt_to_copy = FALSE) {
|
||
| 176 | -+ | |||
| 34 | +5x |
- #' }+ checkmate::assert_flag(with_spaces) |
||
| 177 | -+ | |||
| 35 | +5x |
- #'+ checkmate::assert_flag(print_txt_to_copy) |
||
| 178 | -+ | |||
| 36 | +5x |
- #' @export+ checkmate::assert_int(max_width, null.ok = TRUE) |
||
| 179 | +37 |
- g_km <- function(df,+ |
||
| 180 | -+ | |||
| 38 | +5x |
- variables,+ if (inherits(x, "MatrixPrintForm")) {
|
||
| 181 | -+ | |||
| 39 | +! |
- control_surv = control_surv_timepoint(),+ tx <- x |
||
| 182 | +40 |
- col = NULL,+ } else {
|
||
| 183 | -+ | |||
| 41 | +5x |
- lty = NULL,+ tx <- matrix_form(x, TRUE) |
||
| 184 | +42 |
- lwd = .5,+ } |
||
| 185 | +43 |
- censor_show = TRUE,+ |
||
| 186 | -+ | |||
| 44 | +5x |
- pch = 3,+ tf_wrap <- FALSE |
||
| 187 | -+ | |||
| 45 | +5x |
- size = 2,+ if (!is.null(max_width)) {
|
||
| 188 | -+ | |||
| 46 | +! |
- max_time = NULL,+ tf_wrap <- TRUE |
||
| 189 | +47 |
- xticks = NULL,+ } |
||
| 190 | +48 |
- xlab = "Days",+ |
||
| 191 | +49 |
- yval = c("Survival", "Failure"),
+ # Producing the matrix to test |
||
| 192 | -+ | |||
| 50 | +5x |
- ylab = paste(yval, "Probability"),+ if (with_spaces) {
|
||
| 193 | -+ | |||
| 51 | +! |
- ylim = NULL,+ out <- strsplit(toString(tx, widths = widths, tf_wrap = tf_wrap, max_width = max_width, hsep = hsep), "\\n")[[1]] |
||
| 194 | +52 |
- title = NULL,+ } else {
|
||
| 195 | -+ | |||
| 53 | +5x |
- footnotes = NULL,+ out <- tx$strings |
||
| 196 | +54 |
- draw = TRUE,+ } |
||
| 197 | +55 |
- newpage = TRUE,+ |
||
| 198 | +56 |
- gp = NULL,+ # Printing to console formatted output that needs to be copied in "expected" |
||
| 199 | -+ | |||
| 57 | +5x |
- vp = NULL,+ if (print_txt_to_copy) {
|
||
| 200 | -+ | |||
| 58 | +! |
- name = NULL,+ out_tmp <- out |
||
| 201 | -+ | |||
| 59 | +! |
- font_size = 12,+ if (!with_spaces) {
|
||
| 202 | -+ | |||
| 60 | +! |
- ci_ribbon = FALSE,+ out_tmp <- apply(out, 1, paste0, collapse = '", "') |
||
| 203 | +61 |
- ggtheme = nestcolor::theme_nest(),+ } |
||
| 204 | -+ | |||
| 62 | +! |
- annot_at_risk = TRUE,+ cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
|
||
| 205 | +63 |
- annot_at_risk_title = TRUE,+ } |
||
| 206 | +64 |
- annot_surv_med = TRUE,+ |
||
| 207 | +65 |
- annot_coxph = FALSE,+ # Return values+ |
+ ||
| 66 | +5x | +
+ return(out) |
||
| 208 | +67 |
- annot_stats = NULL,+ } |
||
| 209 | +68 |
- annot_stats_vlines = FALSE,+ |
||
| 210 | +69 |
- control_coxph_pw = control_coxph(),+ #' Blank for Missing Input |
||
| 211 | +70 |
- ref_group_coxph = NULL,+ #' |
||
| 212 | +71 |
- annot_coxph_ref_lbls = FALSE,+ #' Helper function to use in tabulating model results. |
||
| 213 | +72 |
- position_coxph = c(-0.03, -0.02),+ #' |
||
| 214 | +73 |
- position_surv_med = c(0.95, 0.9),+ #' @param x (`vector`)\cr input for a cell. |
||
| 215 | +74 |
- width_annots = list(surv_med = grid::unit(0.3, "npc"), coxph = grid::unit(0.4, "npc"))) {
+ #' |
||
| 216 | -3x | +|||
| 75 | +
- checkmate::assert_list(variables)+ #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise |
|||
| 217 | -3x | +|||
| 76 | +
- checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
+ #' the unlisted version of `x`. |
|||
| 218 | -3x | +|||
| 77 | +
- checkmate::assert_string(title, null.ok = TRUE)+ #' |
|||
| 219 | -3x | +|||
| 78 | +
- checkmate::assert_string(footnotes, null.ok = TRUE)+ #' @keywords internal |
|||
| 220 | -3x | +|||
| 79 | +
- checkmate::assert_character(col, null.ok = TRUE)+ unlist_and_blank_na <- function(x) {
|
|||
| 221 | -3x | +80 | +267x |
- checkmate::assert_subset(annot_stats, c("median", "min"))
+ unl <- unlist(x) |
| 222 | -3x | +81 | +267x |
- checkmate::assert_logical(annot_stats_vlines)+ if (all(is.na(unl))) {
|
| 223 | -3x | +82 | +161x |
- checkmate::assert_true(all(sapply(width_annots, grid::is.unit)))+ character() |
| 224 | +83 |
-
+ } else {
|
||
| 225 | -3x | +84 | +106x |
- tte <- variables$tte+ unl |
| 226 | -3x | +|||
| 85 | +
- is_event <- variables$is_event+ } |
|||
| 227 | -3x | +|||
| 86 | +
- arm <- variables$arm+ } |
|||
| 228 | +87 | |||
| 229 | -3x | +|||
| 88 | +
- assert_valid_factor(df[[arm]])+ #' Constructor for Content Functions given Data Frame with Flag Input |
|||
| 230 | -3x | +|||
| 89 | +
- assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm))+ #' |
|||
| 231 | -3x | +|||
| 90 | +
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ #' This can be useful for tabulating model results. |
|||
| 232 | -3x | +|||
| 91 | +
- checkmate::assert_numeric(df[[tte]], min.len = 1, any.missing = FALSE)+ #' |
|||
| 233 | +92 |
-
+ #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the |
||
| 234 | -3x | +|||
| 93 | +
- armval <- as.character(unique(df[[arm]]))+ #' content function. |
|||
| 235 | -3x | +|||
| 94 | +
- if (annot_coxph && length(armval) < 2) {
+ #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned. |
|||
| 236 | -! | +|||
| 95 | +
- stop(paste(+ #' @param format (`string`)\cr `rtables` format to use. |
|||
| 237 | -! | +|||
| 96 | +
- "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`",+ #' |
|||
| 238 | -! | +|||
| 97 | +
- "in order to calculate the hazard ratio."+ #' @return A content function which gives `df$analysis_var` at the row identified by |
|||
| 239 | +98 |
- ))+ #' `.df_row$flag` in the given format. |
||
| 240 | -3x | +|||
| 99 | +
- } else if (length(armval) > 1) {
+ #' |
|||
| 241 | -3x | +|||
| 100 | +
- armval <- NULL+ #' @keywords internal |
|||
| 242 | +101 |
- }+ cfun_by_flag <- function(analysis_var, |
||
| 243 | -3x | +|||
| 102 | +
- yval <- match.arg(yval)+ flag_var, |
|||
| 244 | -3x | +|||
| 103 | +
- formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
+ format = "xx", |
|||
| 245 | -3x | +|||
| 104 | +
- fit_km <- survival::survfit(+ .indent_mods = NULL) {
|
|||
| 246 | -3x | +105 | +61x |
- formula = formula,+ checkmate::assert_string(analysis_var) |
| 247 | -3x | +106 | +61x |
- data = df,+ checkmate::assert_string(flag_var) |
| 248 | -3x | +107 | +61x |
- conf.int = control_surv$conf_level,+ function(df, labelstr) {
|
| 249 | -3x | +108 | +265x |
- conf.type = control_surv$conf_type+ row_index <- which(df[[flag_var]]) |
| 250 | -+ | |||
| 109 | +265x |
- )+ x <- unlist_and_blank_na(df[[analysis_var]][row_index]) |
||
| 251 | -3x | +110 | +265x |
- data_plot <- h_data_plot(+ formatters::with_label( |
| 252 | -3x | +111 | +265x |
- fit_km = fit_km,+ rcell(x, format = format, indent_mod = .indent_mods), |
| 253 | -3x | +112 | +265x |
- armval = armval,+ labelstr |
| 254 | -3x | +|||
| 113 | +
- max_time = max_time+ ) |
|||
| 255 | +114 |
- )+ } |
||
| 256 | +115 |
-
+ } |
||
| 257 | -3x | +|||
| 116 | +
- xticks <- h_xticks(data = data_plot, xticks = xticks, max_time = max_time)+ |
|||
| 258 | -3x | +|||
| 117 | +
- gg <- h_ggkm(+ #' Content Row Function to Add Row Total to Labels |
|||
| 259 | -3x | +|||
| 118 | +
- data = data_plot,+ #' |
|||
| 260 | -3x | +|||
| 119 | +
- censor_show = censor_show,+ #' This takes the label of the latest row split level and adds the row total from `df` in parentheses. |
|||
| 261 | -3x | +|||
| 120 | +
- pch = pch,+ #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than |
|||
| 262 | -3x | +|||
| 121 | +
- size = size,+ #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`. |
|||
| 263 | -3x | +|||
| 122 | +
- xticks = xticks,+ #' |
|||
| 264 | -3x | +|||
| 123 | +
- xlab = xlab,+ #' @inheritParams argument_convention |
|||
| 265 | -3x | +|||
| 124 | +
- yval = yval,+ #' |
|||
| 266 | -3x | +|||
| 125 | +
- ylab = ylab,+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
|||
| 267 | -3x | +|||
| 126 | +
- ylim = ylim,+ #' |
|||
| 268 | -3x | +|||
| 127 | +
- title = title,+ #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because |
|||
| 269 | -3x | +|||
| 128 | +
- footnotes = footnotes,+ #' the former is already split by columns and will refer to the first column of the data only. |
|||
| 270 | -3x | +|||
| 129 | +
- max_time = max_time,+ #' |
|||
| 271 | -3x | +|||
| 130 | +
- lwd = lwd,+ #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from |
|||
| 272 | -3x | +|||
| 131 | +
- lty = lty,+ #' `alt_counts_df` instead of `df`. |
|||
| 273 | -3x | +|||
| 132 | +
- col = col,+ #' |
|||
| 274 | -3x | +|||
| 133 | +
- ggtheme = ggtheme,+ #' @keywords internal |
|||
| 275 | -3x | +|||
| 134 | +
- ci_ribbon = ci_ribbon+ c_label_n <- function(df, |
|||
| 276 | +135 |
- )+ labelstr, |
||
| 277 | +136 |
-
+ .N_row) { # nolint
|
||
| 278 | -3x | +137 | +270x |
- if (!is.null(annot_stats)) {
+ label <- paste0(labelstr, " (N=", .N_row, ")") |
| 279 | -! | +|||
| 138 | +270x |
- if ("median" %in% annot_stats) {
+ in_rows( |
||
| 280 | -! | +|||
| 139 | +270x |
- fit_km_all <- survival::survfit(+ .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)), |
||
| 281 | -! | +|||
| 140 | +270x |
- formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
+ .formats = c(row_count = function(x, ...) "") |
||
| 282 | -! | +|||
| 141 | +
- data = df,+ ) |
|||
| 283 | -! | +|||
| 142 | +
- conf.int = control_surv$conf_level,+ } |
|||
| 284 | -! | +|||
| 143 | +
- conf.type = control_surv$conf_type+ |
|||
| 285 | +144 |
- )+ #' Content Row Function to Add `alt_counts_df` Row Total to Labels |
||
| 286 | -! | +|||
| 145 | +
- gg <- gg ++ #' |
|||
| 287 | -! | +|||
| 146 | +
- geom_text(+ #' This takes the label of the latest row split level and adds the row total from `alt_counts_df` |
|||
| 288 | -! | +|||
| 147 | +
- size = 8 / ggplot2::.pt, col = 1,+ #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df` |
|||
| 289 | -! | +|||
| 148 | +
- x = stats::median(fit_km_all) + 0.065 * max(data_plot$time),+ #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`. |
|||
| 290 | -! | +|||
| 149 | +
- y = ifelse(yval == "Survival", 0.62, 0.38),+ #' |
|||
| 291 | -! | +|||
| 150 | +
- label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
+ #' @inheritParams argument_convention |
|||
| 292 | +151 |
- )+ #' |
||
| 293 | -! | +|||
| 152 | +
- if (annot_stats_vlines) {
+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
|||
| 294 | -! | +|||
| 153 | +
- gg <- gg ++ #' |
|||
| 295 | -! | +|||
| 154 | +
- geom_segment(aes(x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf),+ #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead |
|||
| 296 | -! | +|||
| 155 | +
- linetype = 2, col = "darkgray"+ #' of `alt_counts_df`. |
|||
| 297 | +156 |
- )+ #' |
||
| 298 | +157 |
- }+ #' @keywords internal |
||
| 299 | +158 |
- }+ c_label_n_alt <- function(df, |
||
| 300 | -! | +|||
| 159 | +
- if ("min" %in% annot_stats) {
+ labelstr, |
|||
| 301 | -! | +|||
| 160 | +
- min_fu <- min(df[[tte]])+ .alt_df_row) {
|
|||
| 302 | -! | +|||
| 161 | +7x |
- gg <- gg ++ N_row_alt <- nrow(.alt_df_row) # nolint |
||
| 303 | -! | +|||
| 162 | +7x |
- geom_text(+ label <- paste0(labelstr, " (N=", N_row_alt, ")") |
||
| 304 | -! | +|||
| 163 | +7x |
- size = 8 / ggplot2::.pt, col = 1,+ in_rows( |
||
| 305 | -! | +|||
| 164 | +7x |
- x = min_fu + max(data_plot$time) * ifelse(yval == "Survival", 0.05, 0.07),+ .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)), |
||
| 306 | -! | +|||
| 165 | +7x |
- y = ifelse(yval == "Survival", 1.0, 0.05),+ .formats = c(row_count = function(x, ...) "") |
||
| 307 | -! | +|||
| 166 | +
- label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
+ ) |
|||
| 308 | +167 |
- )+ } |
||
| 309 | -! | +|||
| 168 | +
- if (annot_stats_vlines) {
+
|
|||
| 310 | -! | +|||
| 169 | +
- gg <- gg ++ #' Layout Creating Function to Add Row Total Counts |
|||
| 311 | -! | +|||
| 170 | +
- geom_segment(aes(x = min_fu, xend = min_fu, y = Inf, yend = -Inf), linetype = 2, col = "darkgray")+ #' |
|||
| 312 | +171 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 313 | +172 |
- }+ #' |
||
| 314 | -! | +|||
| 173 | +
- gg <- gg + ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(shape = NA, label = "")))+ #' This works analogously to [rtables::add_colcounts()] but on the rows. This function |
|||
| 315 | +174 |
- }+ #' is a wrapper for [rtables::summarize_row_groups()]. |
||
| 316 | +175 |
-
+ #' |
||
| 317 | -3x | +|||
| 176 | +
- g_el <- h_decompose_gg(gg)+ #' @inheritParams argument_convention |
|||
| 318 | +177 |
-
+ #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`) |
||
| 319 | -3x | +|||
| 178 | +
- if (annot_at_risk) {
+ #' or from `df` (`FALSE`). Defaults to `FALSE`. |
|||
| 320 | +179 |
- # This is the content of the table that will be below the graph.+ #' |
||
| 321 | -2x | +|||
| 180 | +
- annot_tbl <- summary(fit_km, time = xticks)+ #' @return A modified layout where the latest row split labels now have the row-wise |
|||
| 322 | -2x | +|||
| 181 | +
- annot_tbl <- if (is.null(fit_km$strata)) {
+ #' total counts (i.e. without column-based subsetting) attached in parentheses. |
|||
| 323 | -! | +|||
| 182 | +
- data.frame(+ #' |
|||
| 324 | -! | +|||
| 183 | +
- n.risk = annot_tbl$n.risk,+ #' @note Row count values are contained in these row count rows but are not displayed |
|||
| 325 | -! | +|||
| 184 | +
- time = annot_tbl$time,+ #' so that they are not considered zero rows by default when pruning. |
|||
| 326 | -! | +|||
| 185 | +
- strata = as.factor(armval)+ #' |
|||
| 327 | +186 |
- )+ #' @examples |
||
| 328 | +187 |
- } else {
+ #' basic_table() %>% |
||
| 329 | -2x | +|||
| 188 | +
- strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ #' split_cols_by("ARM") %>%
|
|||
| 330 | -2x | +|||
| 189 | +
- levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ #' add_colcounts() %>% |
|||
| 331 | -2x | +|||
| 190 | +
- data.frame(+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
|||
| 332 | -2x | +|||
| 191 | +
- n.risk = annot_tbl$n.risk,+ #' add_rowcounts() %>% |
|||
| 333 | -2x | +|||
| 192 | +
- time = annot_tbl$time,+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
|
|||
| 334 | -2x | +|||
| 193 | +
- strata = annot_tbl$strata+ #' build_table(DM) |
|||
| 335 | +194 |
- )+ #' |
||
| 336 | +195 |
- }+ #' @export |
||
| 337 | +196 |
-
+ add_rowcounts <- function(lyt, alt_counts = FALSE) {
|
||
| 338 | -2x | +197 | +6x |
- grobs_patient <- h_grob_tbl_at_risk(+ summarize_row_groups( |
| 339 | -2x | +198 | +6x |
- data = data_plot,+ lyt, |
| 340 | -2x | +199 | +6x |
- annot_tbl = annot_tbl,+ cfun = if (alt_counts) c_label_n_alt else c_label_n |
| 341 | -2x | +|||
| 200 | +
- xlim = max(max_time, data_plot$time, xticks),+ ) |
|||
| 342 | -2x | +|||
| 201 | +
- title = annot_at_risk_title+ } |
|||
| 343 | +202 |
- )+ |
||
| 344 | +203 |
- }+ #' Obtain Column Indices |
||
| 345 | +204 |
-
+ #' |
||
| 346 | -3x | +|||
| 205 | +
- if (annot_at_risk || annot_surv_med || annot_coxph) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 347 | -2x | +|||
| 206 | +
- lyt <- h_km_layout(+ #' |
|||
| 348 | -2x | +|||
| 207 | +
- data = data_plot, g_el = g_el, title = title, footnotes = footnotes,+ #' Helper function to extract column indices from a `VTableTree` for a given |
|||
| 349 | -2x | +|||
| 208 | +
- annot_at_risk = annot_at_risk, annot_at_risk_title = annot_at_risk_title+ #' vector of column names. |
|||
| 350 | +209 |
- )+ #' |
||
| 351 | -2x | +|||
| 210 | +
- at_risk_ttl <- as.numeric(annot_at_risk_title)+ #' @param table_tree (`VTableTree`)\cr table to extract the indices from. |
|||
| 352 | -2x | +|||
| 211 | +
- ttl_row <- as.numeric(!is.null(title))+ #' @param col_names (`character`)\cr vector of column names. |
|||
| 353 | -2x | +|||
| 212 | +
- foot_row <- as.numeric(!is.null(footnotes))+ #' |
|||
| 354 | -2x | +|||
| 213 | +
- km_grob <- grid::gTree(+ #' @return A vector of column indices. |
|||
| 355 | -2x | +|||
| 214 | +
- vp = grid::viewport(layout = lyt, height = .95, width = .95),+ #' |
|||
| 356 | -2x | +|||
| 215 | +
- children = grid::gList(+ #' @export |
|||
| 357 | +216 |
- # Title.+ h_col_indices <- function(table_tree, col_names) {
|
||
| 358 | -2x | +217 | +1232x |
- if (ttl_row == 1) {
+ checkmate::assert_class(table_tree, "VTableNodeInfo") |
| 359 | -1x | +218 | +1232x |
- grid::gTree(+ checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE) |
| 360 | -1x | +219 | +1232x |
- vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 2),+ match(col_names, names(attr(col_info(table_tree), "cextra_args"))) |
| 361 | -1x | +|||
| 220 | +
- children = grid::gList(grid::textGrob(label = title, x = grid::unit(0, "npc"), hjust = 0))+ } |
|||
| 362 | +221 |
- )+ |
||
| 363 | +222 |
- },+ #' Labels or Names of List Elements |
||
| 364 | +223 |
-
+ #' |
||
| 365 | +224 |
- # The Kaplan - Meier curve (top-right corner).+ #' Internal helper function for working with nested statistic function results which typically |
||
| 366 | -2x | +|||
| 225 | +
- grid::gTree(+ #' don't have labels but names that we can use. |
|||
| 367 | -2x | +|||
| 226 | +
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),+ #' |
|||
| 368 | -2x | +|||
| 227 | +
- children = grid::gList(g_el$panel)+ #' @param x a list. |
|||
| 369 | +228 |
- ),+ #' |
||
| 370 | +229 |
-
+ #' @return A `character` vector with the labels or names for the list elements. |
||
| 371 | +230 |
- # Survfit summary table (top-right corner).+ #' |
||
| 372 | -2x | +|||
| 231 | +
- if (annot_surv_med) {
+ #' @keywords internal |
|||
| 373 | -2x | +|||
| 232 | +
- grid::gTree(+ labels_or_names <- function(x) {
|
|||
| 374 | -2x | +233 | +131x |
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),+ checkmate::assert_multi_class(x, c("data.frame", "list"))
|
| 375 | -2x | +234 | +131x |
- children = h_grob_median_surv(+ labs <- sapply(x, obj_label) |
| 376 | -2x | +235 | +131x |
- fit_km = fit_km,+ nams <- rlang::names2(x) |
| 377 | -2x | +236 | +131x |
- armval = armval,+ label_is_null <- sapply(labs, is.null) |
| 378 | -2x | +237 | +131x |
- x = position_surv_med[1],+ result <- unlist(ifelse(label_is_null, nams, labs)) |
| 379 | -2x | +238 | +131x |
- y = position_surv_med[2],+ return(result) |
| 380 | -2x | +|||
| 239 | +
- width = if (!is.null(width_annots[["surv_med"]])) width_annots[["surv_med"]] else grid::unit(0.3, "npc"),+ } |
|||
| 381 | -2x | +|||
| 240 | +
- ttheme = gridExtra::ttheme_default(base_size = font_size)+ |
|||
| 382 | +241 |
- )+ #' Convert to `rtable` |
||
| 383 | +242 |
- )+ #' |
||
| 384 | +243 |
- },+ #' @description `r lifecycle::badge("stable")`
|
||
| 385 | -2x | +|||
| 244 | +
- if (annot_coxph) {
+ #' |
|||
| 386 | -1x | +|||
| 245 | +
- grid::gTree(+ #' This is a new generic function to convert objects to `rtable` tables. |
|||
| 387 | -1x | +|||
| 246 | +
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),+ #' |
|||
| 388 | -1x | +|||
| 247 | +
- children = h_grob_coxph(+ #' @param x the object which should be converted to an `rtable`. |
|||
| 389 | -1x | +|||
| 248 | +
- df = df,+ #' @param ... additional arguments for methods. |
|||
| 390 | -1x | +|||
| 249 | +
- variables = variables,+ #' |
|||
| 391 | -1x | +|||
| 250 | +
- control_coxph_pw = control_coxph_pw,+ #' @return An `rtables` table object. Note that the concrete class will depend on the method used. |
|||
| 392 | -1x | +|||
| 251 | +
- ref_group_coxph = ref_group_coxph,+ #' |
|||
| 393 | -1x | +|||
| 252 | +
- annot_coxph_ref_lbls = annot_coxph_ref_lbls,+ #' @export |
|||
| 394 | -1x | +|||
| 253 | +
- x = position_coxph[1],+ as.rtable <- function(x, ...) { # nolint
|
|||
| 395 | -1x | +254 | +3x |
- y = position_coxph[2],+ UseMethod("as.rtable", x)
|
| 396 | -1x | +|||
| 255 | +
- width = if (!is.null(width_annots[["coxph"]])) width_annots[["coxph"]] else grid::unit(0.4, "npc"),+ } |
|||
| 397 | -1x | +|||
| 256 | +
- ttheme = gridExtra::ttheme_default(+ |
|||
| 398 | -1x | +|||
| 257 | +
- base_size = font_size,+ #' @describeIn as.rtable method for converting `data.frame` that contain numeric columns to `rtable`. |
|||
| 399 | -1x | +|||
| 258 | +
- padding = grid::unit(c(1, .5), "lines"),+ #' |
|||
| 400 | -1x | +|||
| 259 | +
- core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+ #' @param format the format which should be used for the columns. |
|||
| 401 | +260 |
- )+ #' |
||
| 402 | +261 |
- )+ #' @method as.rtable data.frame |
||
| 403 | +262 |
- )+ #' |
||
| 404 | +263 |
- },+ #' @examples |
||
| 405 | +264 |
-
+ #' x <- data.frame( |
||
| 406 | +265 |
- # Add the y-axis annotation (top-left corner).+ #' a = 1:10, |
||
| 407 | -2x | +|||
| 266 | +
- grid::gTree(+ #' b = rnorm(10) |
|||
| 408 | -2x | +|||
| 267 | +
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 1),+ #' ) |
|||
| 409 | -2x | +|||
| 268 | +
- children = h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)+ #' as.rtable(x) |
|||
| 410 | +269 |
- ),+ #' |
||
| 411 | +270 |
-
+ #' @export |
||
| 412 | +271 |
- # Add the x-axis annotation (second row below the Kaplan Meier Curve).+ as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
|
||
| 413 | -2x | +272 | +3x |
- grid::gTree(+ checkmate::assert_numeric(unlist(x)) |
| 414 | +273 | 2x |
- vp = grid::viewport(layout.pos.row = 2 + ttl_row, layout.pos.col = 2),+ do.call( |
|
| 415 | +274 | 2x |
- children = grid::gList(rbind(g_el$xaxis, g_el$xlab))- |
- |
| 416 | -- |
- ),- |
- ||
| 417 | -- |
-
+ rtable, |
||
| 418 | -+ | |||
| 275 | +2x |
- # Add the legend.+ c( |
||
| 419 | +276 | 2x |
- grid::gTree(+ list( |
|
| 420 | +277 | 2x |
- vp = grid::viewport(layout.pos.row = 3 + ttl_row, layout.pos.col = 2),+ header = labels_or_names(x), |
|
| 421 | +278 | 2x |
- children = grid::gList(g_el$guide)+ format = format |
|
| 422 | +279 |
- ),+ ), |
||
| 423 | -+ | |||
| 280 | +2x |
-
+ Map( |
||
| 424 | -+ | |||
| 281 | +2x |
- # Add the table with patient-at-risk numbers.+ function(row, row_name) {
|
||
| 425 | -2x | +282 | +20x |
- if (annot_at_risk && annot_at_risk_title) {
+ do.call( |
| 426 | -2x | +283 | +20x |
- grid::gTree(+ rrow, |
| 427 | -2x | +284 | +20x |
- vp = grid::viewport(layout.pos.row = 4 + ttl_row, layout.pos.col = 1),+ c(as.list(unname(row)), |
| 428 | -2x | +285 | +20x |
- children = grobs_patient$title+ row.name = row_name |
| 429 | +286 | ++ |
+ )+ |
+ |
| 287 |
) |
|||
| 430 | +288 |
}, |
||
| 431 | +289 | 2x |
- if (annot_at_risk) {
+ row = as.data.frame(t(x)), |
|
| 432 | +290 | 2x |
- grid::gTree(+ row_name = rownames(x) |
|
| 433 | -2x | +|||
| 291 | +
- vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 2),+ ) |
|||
| 434 | -2x | +|||
| 292 | +
- children = grobs_patient$at_risk+ ) |
|||
| 435 | +293 | ++ |
+ )+ |
+ |
| 294 |
- )+ } |
|||
| 436 | +295 |
- },+ |
||
| 437 | -2x | +|||
| 296 | +
- if (annot_at_risk) {
+ #' Split parameters |
|||
| 438 | -2x | +|||
| 297 | +
- grid::gTree(+ #' |
|||
| 439 | -2x | +|||
| 298 | +
- vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 1),+ #' @description `r lifecycle::badge("stable")`
|
|||
| 440 | -2x | +|||
| 299 | +
- children = grobs_patient$label+ #' |
|||
| 441 | +300 |
- )+ #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant |
||
| 442 | +301 |
- },+ #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to |
||
| 443 | -2x | +|||
| 302 | +
- if (annot_at_risk) {
+ #' specific analysis function. |
|||
| 444 | +303 |
- # Add the x-axis for the table.+ #' |
||
| 445 | -2x | +|||
| 304 | +
- grid::gTree(+ #' @param param (`vector`)\cr the parameter to be split. |
|||
| 446 | -2x | +|||
| 305 | +
- vp = grid::viewport(layout.pos.row = 5 + at_risk_ttl + ttl_row, layout.pos.col = 2),+ #' @param value (`vector`)\cr the value used to split. |
|||
| 447 | -2x | +|||
| 306 | +
- children = grid::gList(rbind(g_el$xaxis, g_el$xlab))+ #' @param f (`list` of `vectors`)\cr the reference to make the split |
|||
| 448 | +307 |
- )+ #' |
||
| 449 | +308 |
- },+ #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`. |
||
| 450 | +309 |
-
+ #' |
||
| 451 | +310 |
- # Footnotes.+ #' @examples |
||
| 452 | -2x | +|||
| 311 | +
- if (foot_row == 1) {
+ #' f <- list( |
|||
| 453 | -1x | +|||
| 312 | +
- grid::gTree(+ #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
|||
| 454 | -1x | +|||
| 313 | +
- vp = grid::viewport(+ #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
|||
| 455 | -1x | +|||
| 314 | +
- layout.pos.row = ifelse(annot_at_risk, 6 + at_risk_ttl + ttl_row, 4 + ttl_row),+ #' ) |
|||
| 456 | -1x | +|||
| 315 | +
- layout.pos.col = 2+ #' |
|||
| 457 | +316 |
- ),+ #' .stats <- c("pt_at_risk", "rate_diff")
|
||
| 458 | -1x | +|||
| 317 | +
- children = grid::gList(grid::textGrob(label = footnotes, x = grid::unit(0, "npc"), hjust = 0))+ #' h_split_param(.stats, .stats, f = f) |
|||
| 459 | +318 |
- )+ #' |
||
| 460 | +319 |
- }+ #' # $surv |
||
| 461 | +320 |
- )+ #' # [1] "pt_at_risk" |
||
| 462 | +321 |
- )+ #' # |
||
| 463 | +322 |
-
+ #' # $surv_diff |
||
| 464 | -2x | +|||
| 323 | +
- result <- grid::gTree(+ #' # [1] "rate_diff" |
|||
| 465 | -2x | +|||
| 324 | +
- vp = vp,+ #' |
|||
| 466 | -2x | +|||
| 325 | +
- gp = gp,+ #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
|
|||
| 467 | -2x | +|||
| 326 | +
- name = name,+ #' h_split_param(.formats, names(.formats), f = f) |
|||
| 468 | -2x | +|||
| 327 | +
- children = grid::gList(km_grob)+ #' |
|||
| 469 | +328 |
- )+ #' # $surv |
||
| 470 | +329 |
- } else {
+ #' # pt_at_risk event_free_rate |
||
| 471 | -1x | +|||
| 330 | +
- result <- grid::gTree(+ #' # "xx" "xxx" |
|||
| 472 | -1x | +|||
| 331 | +
- vp = vp,+ #' # |
|||
| 473 | -1x | +|||
| 332 | +
- gp = gp,+ #' # $surv_diff |
|||
| 474 | -1x | +|||
| 333 | +
- name = name,+ #' # NULL |
|||
| 475 | -1x | +|||
| 334 | +
- children = grid::gList(ggplot2::ggplotGrob(gg))+ #' |
|||
| 476 | +335 |
- )+ #' @export |
||
| 477 | +336 |
- }+ h_split_param <- function(param, |
||
| 478 | +337 |
-
+ value, |
||
| 479 | -3x | +|||
| 338 | +
- if (newpage && draw) grid::grid.newpage()+ f) {
|
|||
| 480 | -3x | +339 | +25x |
- if (draw) grid::grid.draw(result)+ y <- lapply(f, function(x) param[value %in% x]) |
| 481 | -3x | +340 | +25x |
- invisible(result)+ lapply(y, function(x) if (length(x) == 0) NULL else x) |
| 482 | +341 |
} |
||
| 483 | +342 | |||
| 484 | +343 |
- #' Helper function: tidy survival fit+ #' Get Selected Statistics Names |
||
| 485 | +344 |
#' |
||
| 486 | +345 |
- #' @description `r lifecycle::badge("stable")`
+ #' Helper function to be used for creating `afun`. |
||
| 487 | +346 |
#' |
||
| 488 | +347 |
- #' Convert the survival fit data into a data frame designed for plotting+ #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means |
||
| 489 | +348 |
- #' within `g_km`.+ #' in this context that all default statistics should be used. |
||
| 490 | +349 |
- #'+ #' @param all_stats (`character`)\cr all statistics which can be selected here potentially. |
||
| 491 | +350 |
- #' This starts from the [broom::tidy()] result, and then:+ #' |
||
| 492 | +351 |
- #' * Post-processes the `strata` column into a factor.+ #' @return A `character` vector with the selected statistics. |
||
| 493 | +352 |
- #' * Extends each stratum by an additional first row with time 0 and probability 1 so that+ #' |
||
| 494 | +353 |
- #' downstream plot lines start at those coordinates.+ #' @keywords internal |
||
| 495 | +354 |
- #' * Adds a `censor` column.+ afun_selected_stats <- function(.stats, all_stats) {
+ |
+ ||
| 355 | +2x | +
+ checkmate::assert_character(.stats, null.ok = TRUE)+ |
+ ||
| 356 | +2x | +
+ checkmate::assert_character(all_stats)+ |
+ ||
| 357 | +2x | +
+ if (is.null(.stats)) {
+ |
+ ||
| 358 | +1x | +
+ all_stats |
||
| 496 | +359 |
- #' * Filters the rows before `max_time`.+ } else {
+ |
+ ||
| 360 | +1x | +
+ intersect(.stats, all_stats) |
||
| 497 | +361 |
- #'+ } |
||
| 498 | +362 |
- #' @inheritParams g_km+ } |
||
| 499 | +363 |
- #' @param fit_km (`survfit`)\cr result of [survival::survfit()].+ |
||
| 500 | +364 |
- #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`.+ #' Add Variable Labels to Top Left Corner in Table |
||
| 501 | +365 |
#' |
||
| 502 | +366 |
- #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`,+ #' @description `r lifecycle::badge("stable")`
|
||
| 503 | +367 |
- #' `conf.low`, `strata`, and `censor`.+ #' |
||
| 504 | +368 |
- #'+ #' Helper layout creating function to just append the variable labels of a given variables vector |
||
| 505 | +369 |
- #' @examples+ #' from a given dataset in the top left corner. If a variable label is not found then the |
||
| 506 | +370 |
- #' \donttest{
+ #' variable name itself is used instead. Multiple variable labels are concatenated with slashes. |
||
| 507 | +371 |
- #' library(dplyr)+ #' |
||
| 508 | +372 |
- #' library(survival)+ #' @inheritParams argument_convention |
||
| 509 | +373 |
- #'+ #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`. |
||
| 510 | +374 |
- #' # Test with multiple arms+ #' @param indent (`integer`)\cr non-negative number of nested indent space, default to 0L which means no indent. |
||
| 511 | +375 |
- #' tern_ex_adtte %>%+ #' 1L means two spaces indent, 2L means four spaces indent and so on. |
||
| 512 | +376 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 513 | +377 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' @return A modified layout with the new variable label(s) added to the top-left material. |
||
| 514 | +378 |
- #' h_data_plot()+ #' |
||
| 515 | +379 |
- #'+ #' @note This is not an optimal implementation of course, since we are using here the data set |
||
| 516 | +380 |
- #' # Test with single arm+ #' itself during the layout creation. When we have a more mature `rtables` implementation then |
||
| 517 | +381 |
- #' tern_ex_adtte %>%+ #' this will also be improved or not necessary anymore. |
||
| 518 | +382 |
- #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>%+ #' |
||
| 519 | +383 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' @examples |
||
| 520 | +384 |
- #' h_data_plot(armval = "ARM B")+ #' lyt <- basic_table() %>% |
||
| 521 | +385 |
- #' }+ #' split_cols_by("ARM") %>%
|
||
| 522 | +386 |
- #'+ #' add_colcounts() %>% |
||
| 523 | +387 |
- #' @export+ #' split_rows_by("SEX") %>%
|
||
| 524 | +388 |
- h_data_plot <- function(fit_km,+ #' append_varlabels(DM, "SEX") %>% |
||
| 525 | +389 |
- armval = "All",+ #' analyze("AGE", afun = mean) %>%
|
||
| 526 | +390 |
- max_time = NULL) {
+ #' append_varlabels(DM, "AGE", indent = 1) |
||
| 527 | -10x | +|||
| 391 | +
- y <- broom::tidy(fit_km)+ #' build_table(lyt, DM) |
|||
| 528 | +392 |
-
+ #' |
||
| 529 | -10x | +|||
| 393 | +
- if (!is.null(fit_km$strata)) {
+ #' lyt <- basic_table() %>% |
|||
| 530 | -10x | +|||
| 394 | +
- fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
+ #' split_cols_by("ARM") %>%
|
|||
| 531 | -10x | +|||
| 395 | +
- strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2)+ #' split_rows_by("SEX") %>%
|
|||
| 532 | -10x | +|||
| 396 | +
- strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
+ #' analyze("AGE", afun = mean) %>%
|
|||
| 533 | -10x | +|||
| 397 | +
- y$strata <- factor(+ #' append_varlabels(DM, c("SEX", "AGE"))
|
|||
| 534 | -10x | +|||
| 398 | +
- vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2),+ #' build_table(lyt, DM) |
|||
| 535 | -10x | +|||
| 399 | +
- levels = strata_levels+ #' |
|||
| 536 | +400 |
- )+ #' @export |
||
| 537 | +401 |
- } else {
+ append_varlabels <- function(lyt, df, vars, indent = 0L) {
+ |
+ ||
| 402 | +3x | +
+ if (checkmate::test_flag(indent)) {
|
||
| 538 | +403 | ! |
- y$strata <- armval+ warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
+ |
+ |
| 404 | +! | +
+ indent <- as.integer(indent) |
||
| 539 | +405 |
} |
||
| 540 | +406 | |||
| 541 | -10x | +407 | +3x |
- y_by_strata <- split(y, y$strata)+ checkmate::assert_data_frame(df) |
| 542 | -10x | +408 | +3x |
- y_by_strata_extended <- lapply(+ checkmate::assert_character(vars) |
| 543 | -10x | +409 | +3x |
- y_by_strata,+ checkmate::assert_count(indent) |
| 544 | -10x | +|||
| 410 | +
- FUN = function(tbl) {
+
|
|||
| 545 | -30x | +411 | +3x |
- first_row <- tbl[1L, ]+ lab <- formatters::var_labels(df[vars], fill = TRUE) |
| 546 | -30x | +412 | +3x |
- first_row$time <- 0+ lab <- paste(lab, collapse = " / ") |
| 547 | -30x | +413 | +3x |
- first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
+ space <- paste(rep(" ", indent * 2), collapse = "")
|
| 548 | -30x | +414 | +3x |
- first_row$n.event <- first_row$n.censor <- 0+ lab <- paste0(space, lab) |
| 549 | -30x | +|||
| 415 | +
- first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1+ |
|||
| 550 | -30x | +416 | +3x |
- first_row$std.error <- 0+ append_topleft(lyt, lab) |
| 551 | -30x | +|||
| 417 | +
- rbind(+ } |
|||
| 552 | -30x | +|||
| 418 | +
- first_row,+ |
|||
| 553 | -30x | +|||
| 419 | +
- tbl+ #' Default string replacement for `NA` values |
|||
| 554 | +420 |
- )+ #' |
||
| 555 | +421 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 556 | +422 |
- )+ #' |
||
| 557 | -10x | +|||
| 423 | +
- y <- do.call(rbind, y_by_strata_extended)+ #' The default string used to represent `NA` values. This value is used as the default |
|||
| 558 | +424 |
-
+ #' value for the `na_str` argument throughout the `tern` package, and printed in place |
||
| 559 | -10x | +|||
| 425 | +
- y$censor <- ifelse(y$n.censor > 0, y$estimate, NA)+ #' of `NA` values in output tables. If not specified for each `tern` function by the user |
|||
| 560 | -10x | +|||
| 426 | +
- if (!is.null(max_time)) {
+ #' via the `na_str` argument, or in the R environment options via [set_default_na_str()], |
|||
| 561 | -2x | +|||
| 427 | +
- y <- y[y$time <= max(max_time), ]+ #' then `NA` is used. |
|||
| 562 | +428 |
- }+ #' |
||
| 563 | -10x | +|||
| 429 | +
- y+ #' @param na_str (`string`)\cr Single string value to set in the R environment options as |
|||
| 564 | +430 |
- }+ #' the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the
|
||
| 565 | +431 |
-
+ #' current value set in the R environment (defaults to `NULL` if not set). |
||
| 566 | +432 |
- #' Helper function: x tick positions+ #' |
||
| 567 | +433 |
- #'+ #' @name default_na_str |
||
| 568 | +434 |
- #' @description `r lifecycle::badge("stable")`
+ NULL |
||
| 569 | +435 |
- #'+ |
||
| 570 | +436 |
- #' Calculate the positions of ticks on the x-axis. However, if `xticks` already+ #' @describeIn default_na_str Getter for default `NA` value replacement string. |
||
| 571 | +437 |
- #' exists it is kept as is. It is based on the same function `ggplot2` relies on,+ #' |
||
| 572 | +438 |
- #' and is required in the graphic and the patient-at-risk annotation table.+ #' @return |
||
| 573 | +439 |
- #'+ #' * `default_na_str` returns the current value if an R environment option has been set |
||
| 574 | +440 |
- #' @inheritParams g_km+ #' for `"tern_default_na_str"`, or `NA_character_` otherwise. |
||
| 575 | +441 |
- #' @inheritParams h_ggkm+ #' |
||
| 576 | +442 |
- #'+ #' @examples |
||
| 577 | +443 |
- #' @return A vector of positions to use for x-axis ticks on a `ggplot` object.+ #' # Default settings |
||
| 578 | +444 |
- #'+ #' default_na_str() |
||
| 579 | +445 |
- #' @examples+ #' getOption("tern_default_na_str")
|
||
| 580 | +446 |
- #' \donttest{
+ #' |
||
| 581 | +447 |
- #' library(dplyr)+ #' # Set custom value |
||
| 582 | +448 |
- #' library(survival)+ #' set_default_na_str("<Missing>")
|
||
| 583 | +449 |
#' |
||
| 584 | +450 |
- #' data <- tern_ex_adtte %>%+ #' # Settings after value has been set |
||
| 585 | +451 |
- #' filter(PARAMCD == "OS") %>%+ #' default_na_str() |
||
| 586 | +452 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' getOption("tern_default_na_str")
|
||
| 587 | +453 |
- #' h_data_plot()+ #' |
||
| 588 | +454 |
- #'+ #' @export |
||
| 589 | +455 |
- #' h_xticks(data)+ default_na_str <- function() {
+ |
+ ||
| 456 | +246x | +
+ getOption("tern_default_na_str", default = NA_character_)
|
||
| 590 | +457 |
- #' h_xticks(data, xticks = seq(0, 3000, 500))+ } |
||
| 591 | +458 |
- #' h_xticks(data, xticks = 500)+ |
||
| 592 | +459 |
- #' h_xticks(data, xticks = 500, max_time = 6000)+ #' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the |
||
| 593 | +460 |
- #' h_xticks(data, xticks = c(0, 500), max_time = 300)+ #' option `"tern_default_na_str"` within the R environment. |
||
| 594 | +461 |
- #' h_xticks(data, xticks = 500, max_time = 300)+ #' |
||
| 595 | +462 |
- #' }+ #' @return |
||
| 596 | +463 |
- #'+ #' * `set_default_na_str` has no return value. |
||
| 597 | +464 |
- #' @export+ #' |
||
| 598 | +465 |
- h_xticks <- function(data, xticks = NULL, max_time = NULL) {
+ #' @export |
||
| 599 | -10x | +|||
| 466 | +
- if (is.null(xticks)) {
+ set_default_na_str <- function(na_str) {
|
|||
| 600 | -4x | +467 | +3x |
- if (is.null(max_time)) {
+ checkmate::assert_character(na_str, len = 1, null.ok = TRUE) |
| 601 | +468 | 3x |
- labeling::extended(range(data$time)[1], range(data$time)[2], m = 5)+ options("tern_default_na_str" = na_str)
|
|
| 602 | +469 |
- } else {
- |
- ||
| 603 | -1x | -
- labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5)+ } |
| 604 | +1 |
- }+ #' Subgroup Treatment Effect Pattern (STEP) Fit for Binary (Response) Outcome |
||
| 605 | -6x | +|||
| 2 | +
- } else if (checkmate::test_number(xticks)) {
+ #' |
|||
| 606 | -3x | +|||
| 3 | +
- if (is.null(max_time)) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 607 | -2x | +|||
| 4 | +
- seq(0, max(data$time), xticks)+ #' |
|||
| 608 | +5 |
- } else {
+ #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary |
||
| 609 | -1x | +|||
| 6 | +
- seq(0, max(data$time, max_time), xticks)+ #' (response) outcome. The treatment arm variable must have exactly 2 levels, |
|||
| 610 | +7 |
- }+ #' where the first one is taken as reference and the estimated odds ratios are |
||
| 611 | -3x | +|||
| 8 | +
- } else if (is.numeric(xticks)) {
+ #' for the comparison of the second level vs. the first one. |
|||
| 612 | -2x | +|||
| 9 | +
- xticks+ #' |
|||
| 613 | +10 |
- } else {
+ #' The (conditional) logistic regression model which is fit is: |
||
| 614 | -1x | +|||
| 11 | +
- stop(+ #' |
|||
| 615 | -1x | +|||
| 12 | +
- paste(+ #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
|||
| 616 | -1x | +|||
| 13 | +
- "xticks should be either `NULL`",+ #' |
|||
| 617 | -1x | +|||
| 14 | +
- "or a single number (interval between x ticks)",+ #' where `degree` is specified by `control_step()`. |
|||
| 618 | -1x | +|||
| 15 | +
- "or a numeric vector (position of ticks on the x axis)"+ #' |
|||
| 619 | +16 |
- )+ #' @inheritParams argument_convention |
||
| 620 | +17 |
- )+ #' @param variables (named `list` of `character`)\cr list of analysis variables: |
||
| 621 | +18 |
- }+ #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`. |
||
| 622 | +19 |
- }+ #' @param control (named `list`)\cr combined control list from [control_step()] |
||
| 623 | +20 |
-
+ #' and [control_logistic()]. |
||
| 624 | +21 |
- #' Helper function: KM plot+ #' |
||
| 625 | +22 |
- #'+ #' @return A matrix of class `step`. The first part of the columns describe the |
||
| 626 | +23 |
- #' @description `r lifecycle::badge("stable")`
+ #' subgroup intervals used for the biomarker variable, including where the |
||
| 627 | +24 |
- #'+ #' center of the intervals are and their bounds. The second part of the |
||
| 628 | +25 |
- #' Draw the Kaplan-Meier plot using `ggplot2`.+ #' columns contain the estimates for the treatment arm comparison. |
||
| 629 | +26 |
#' |
||
| 630 | +27 |
- #' @inheritParams g_km+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
||
| 631 | +28 |
- #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`.+ #' |
||
| 632 | +29 |
- #'+ #' @seealso [control_step()] and [control_logistic()] for the available |
||
| 633 | +30 |
- #' @return A `ggplot` object.+ #' customization options. |
||
| 634 | +31 |
#' |
||
| 635 | +32 |
#' @examples |
||
| 636 | +33 |
- #' \donttest{
+ #' # Testing dataset with just two treatment arms. |
||
| 637 | +34 |
- #' library(dplyr)+ #' library(survival) |
||
| 638 | +35 |
- #' library(survival)+ #' library(dplyr) |
||
| 639 | +36 |
#' |
||
| 640 | +37 |
- #' fit_km <- tern_ex_adtte %>%+ #' adrs_f <- tern_ex_adrs %>% |
||
| 641 | +38 |
- #' filter(PARAMCD == "OS") %>%+ #' filter( |
||
| 642 | +39 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' PARAMCD == "BESRSPI", |
||
| 643 | +40 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 644 | +41 |
- #' xticks <- h_xticks(data = data_plot)+ #' ) %>% |
||
| 645 | +42 |
- #' gg <- h_ggkm(+ #' mutate( |
||
| 646 | +43 |
- #' data = data_plot,+ #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations. |
||
| 647 | +44 |
- #' censor_show = TRUE,+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 648 | +45 |
- #' xticks = xticks,+ #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 649 | +46 |
- #' xlab = "Days",+ #' SEX = factor(SEX) |
||
| 650 | +47 |
- #' yval = "Survival",+ #' ) |
||
| 651 | +48 |
- #' ylab = "Survival Probability",+ #' |
||
| 652 | +49 |
- #' title = "Survival"+ #' variables <- list( |
||
| 653 | +50 |
- #' )+ #' arm = "ARM", |
||
| 654 | +51 |
- #' gg+ #' biomarker = "BMRKR1", |
||
| 655 | +52 |
- #' }+ #' covariates = "AGE", |
||
| 656 | +53 |
- #'+ #' response = "RSP" |
||
| 657 | +54 |
- #' @export+ #' ) |
||
| 658 | +55 |
- h_ggkm <- function(data,+ #' |
||
| 659 | +56 |
- xticks = NULL,+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
||
| 660 | +57 |
- yval = "Survival",+ #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those. |
||
| 661 | +58 |
- censor_show,+ #' step_matrix <- fit_rsp_step( |
||
| 662 | +59 |
- xlab,+ #' variables = variables, |
||
| 663 | +60 |
- ylab,+ #' data = adrs_f, |
||
| 664 | +61 |
- ylim = NULL,+ #' control = c(control_logistic(), control_step(bandwidth = 0.9)) |
||
| 665 | +62 |
- title,+ #' ) |
||
| 666 | +63 |
- footnotes = NULL,+ #' dim(step_matrix) |
||
| 667 | +64 |
- max_time = NULL,+ #' head(step_matrix) |
||
| 668 | +65 |
- lwd = 1,+ #' |
||
| 669 | +66 |
- lty = NULL,+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
||
| 670 | +67 |
- pch = 3,+ #' # models. Or specify different logistic regression options, including confidence level. |
||
| 671 | +68 |
- size = 2,+ #' step_matrix2 <- fit_rsp_step( |
||
| 672 | +69 |
- col = NULL,+ #' variables = variables, |
||
| 673 | +70 |
- ci_ribbon = FALSE,+ #' data = adrs_f, |
||
| 674 | +71 |
- ggtheme = nestcolor::theme_nest()) {
+ #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = NULL, degree = 1)) |
||
| 675 | -3x | +|||
| 72 | +
- checkmate::assert_numeric(lty, null.ok = TRUE)+ #' ) |
|||
| 676 | -3x | +|||
| 73 | +
- checkmate::assert_character(col, null.ok = TRUE)+ #' |
|||
| 677 | +74 |
-
+ #' # Use a global constant model. This is helpful as a reference for the subgroup models. |
||
| 678 | -3x | +|||
| 75 | +
- if (is.null(ylim)) {
+ #' step_matrix3 <- fit_rsp_step( |
|||
| 679 | -3x | +|||
| 76 | +
- data_lims <- data+ #' variables = variables, |
|||
| 680 | -1x | +|||
| 77 | +
- if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]]+ #' data = adrs_f, |
|||
| 681 | -3x | +|||
| 78 | +
- if (!is.null(max_time)) {
+ #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L)) |
|||
| 682 | -! | +|||
| 79 | +
- y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]])+ #' ) |
|||
| 683 | -! | +|||
| 80 | +
- y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]])+ #' |
|||
| 684 | +81 |
- } else {
+ #' # It is also possible to use strata, i.e. use conditional logistic regression models. |
||
| 685 | -3x | +|||
| 82 | +
- y_lwr <- min(data_lims[["estimate"]])+ #' variables2 <- list( |
|||
| 686 | -3x | +|||
| 83 | +
- y_upr <- max(data_lims[["estimate"]])+ #' arm = "ARM", |
|||
| 687 | +84 |
- }+ #' biomarker = "BMRKR1", |
||
| 688 | -3x | +|||
| 85 | +
- ylim <- c(y_lwr, y_upr)+ #' covariates = "AGE", |
|||
| 689 | +86 |
- }+ #' response = "RSP", |
||
| 690 | -3x | +|||
| 87 | +
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE)+ #' strata = c("STRATA1", "STRATA2")
|
|||
| 691 | +88 |
-
+ #' ) |
||
| 692 | +89 |
- # change estimates of survival to estimates of failure (1 - survival)+ #' |
||
| 693 | -3x | +|||
| 90 | +
- if (yval == "Failure") {
+ #' step_matrix4 <- fit_rsp_step( |
|||
| 694 | -1x | +|||
| 91 | +
- data$estimate <- 1 - data$estimate+ #' variables = variables2, |
|||
| 695 | -1x | +|||
| 92 | +
- data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
+ #' data = adrs_f, |
|||
| 696 | -1x | +|||
| 93 | +
- data$censor <- 1 - data$censor+ #' control = c(control_logistic(), control_step(bandwidth = NULL)) |
|||
| 697 | +94 |
- }+ #' ) |
||
| 698 | +95 |
-
+ #' |
||
| 699 | -3x | +|||
| 96 | +
- gg <- {
+ #' @export |
|||
| 700 | -3x | +|||
| 97 | +
- ggplot2::ggplot(+ fit_rsp_step <- function(variables, |
|||
| 701 | -3x | +|||
| 98 | +
- data = data,+ data, |
|||
| 702 | -3x | +|||
| 99 | +
- mapping = ggplot2::aes(+ control = c(control_step(), control_logistic())) {
|
|||
| 703 | -3x | +100 | +5x |
- x = .data[["time"]],+ assert_df_with_variables(data, variables) |
| 704 | -3x | +101 | +5x |
- y = .data[["estimate"]],+ checkmate::assert_list(control, names = "named") |
| 705 | -3x | +102 | +5x |
- ymin = .data[["conf.low"]],+ data <- data[!is.na(data[[variables$biomarker]]), ] |
| 706 | -3x | +103 | +5x |
- ymax = .data[["conf.high"]],+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
| 707 | -3x | +104 | +5x |
- color = .data[["strata"]],+ interval_center <- window_sel$interval[, "Interval Center"] |
| 708 | -3x | +105 | +5x |
- fill = .data[["strata"]]+ form <- h_step_rsp_formula(variables = variables, control = control) |
| 709 | -+ | |||
| 106 | +5x |
- )+ estimates <- if (is.null(control$bandwidth)) {
|
||
| 710 | -+ | |||
| 107 | +1x |
- ) ++ h_step_rsp_est( |
||
| 711 | -3x | +108 | +1x |
- ggplot2::geom_hline(yintercept = 0)+ formula = form, |
| 712 | -+ | |||
| 109 | +1x |
- }+ data = data, |
||
| 713 | -+ | |||
| 110 | +1x |
-
+ variables = variables, |
||
| 714 | -3x | +111 | +1x |
- if (ci_ribbon) {
+ x = interval_center, |
| 715 | -! | +|||
| 112 | +1x |
- gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0)+ control = control |
||
| 716 | +113 |
- }+ ) |
||
| 717 | +114 |
-
+ } else {
|
||
| 718 | -3x | +115 | +4x |
- gg <- if (is.null(lty)) {
+ tmp <- mapply( |
| 719 | -2x | +116 | +4x |
- gg ++ FUN = h_step_rsp_est, |
| 720 | -2x | +117 | +4x |
- ggplot2::geom_step(linewidth = lwd)+ x = interval_center, |
| 721 | -3x | +118 | +4x |
- } else if (checkmate::test_number(lty)) {
+ subset = as.list(as.data.frame(window_sel$sel)), |
| 722 | -1x | +119 | +4x |
- gg ++ MoreArgs = list( |
| 723 | -1x | +120 | +4x |
- ggplot2::geom_step(linewidth = lwd, lty = lty)+ formula = form, |
| 724 | -3x | +121 | +4x |
- } else if (is.numeric(lty)) {
+ data = data, |
| 725 | -! | +|||
| 122 | +4x |
- gg ++ variables = variables, |
||
| 726 | -! | +|||
| 123 | +4x |
- ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ control = control |
||
| 727 | -! | +|||
| 124 | +
- ggplot2::scale_linetype_manual(values = lty)+ ) |
|||
| 728 | +125 |
- }+ ) |
||
| 729 | +126 |
-
+ # Maybe we find a more elegant solution than this. |
||
| 730 | -3x | +127 | +4x |
- gg <- gg ++ rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
|
| 731 | -3x | +128 | +4x |
- ggplot2::coord_cartesian(ylim = ylim) ++ t(tmp)+ |
+
| 129 | ++ |
+ } |
||
| 732 | -3x | +130 | +5x |
- ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes)+ result <- cbind(window_sel$interval, estimates) |
| 733 | -+ | |||
| 131 | +5x |
-
+ structure( |
||
| 734 | -3x | +132 | +5x |
- if (!is.null(col)) {
+ result, |
| 735 | -! | +|||
| 133 | +5x |
- gg <- gg ++ class = c("step", "matrix"),
|
||
| 736 | -! | +|||
| 134 | +5x |
- ggplot2::scale_color_manual(values = col) ++ variables = variables, |
||
| 737 | -! | +|||
| 135 | +5x |
- ggplot2::scale_fill_manual(values = col)+ control = control |
||
| 738 | +136 |
- }+ ) |
||
| 739 | -3x | +|||
| 137 | +
- if (censor_show) {
+ } |
|||
| 740 | -3x | +
| 1 | +
- dt <- data[data$n.censor != 0, ]+ #' Occurrence Counts |
|||
| 741 | -3x | +|||
| 2 | +
- dt$censor_lbl <- factor("Censored")
+ #' |
|||
| 742 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 743 | -3x | +|||
| 4 | +
- gg <- gg + ggplot2::geom_point(+ #' |
|||
| 744 | -3x | +|||
| 5 | +
- data = dt,+ #' Functions for analyzing frequencies and fractions of occurrences for patients with occurrence |
|||
| 745 | -3x | +|||
| 6 | +
- ggplot2::aes(+ #' data. Primary analysis variables are the dictionary terms. All occurrences are counted for total |
|||
| 746 | -3x | +|||
| 7 | +
- x = .data[["time"]],+ #' counts. Multiple occurrences within patient at the lowest term level displayed in the table are |
|||
| 747 | -3x | +|||
| 8 | +
- y = .data[["censor"]],+ #' counted only once. |
|||
| 748 | -3x | +|||
| 9 | +
- shape = .data[["censor_lbl"]]+ #' |
|||
| 749 | +10 |
- ),+ #' @inheritParams argument_convention |
||
| 750 | -3x | +|||
| 11 | +
- size = size,+ #' @param drop (`flag`)\cr should non appearing occurrence levels be dropped from the resulting table. |
|||
| 751 | -3x | +|||
| 12 | +
- show.legend = TRUE,+ #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically. |
|||
| 752 | -3x | +|||
| 13 | +
- inherit.aes = TRUE+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_occurrences")`
|
|||
| 753 | +14 |
- ) ++ #' to see available statistics for this function. |
||
| 754 | -3x | +|||
| 15 | +
- ggplot2::scale_shape_manual(name = NULL, values = pch) ++ #' |
|||
| 755 | -3x | +|||
| 16 | +
- ggplot2::guides(+ #' @note By default, occurrences which don't appear in a given row split are dropped from the table and |
|||
| 756 | -3x | +|||
| 17 | +
- shape = ggplot2::guide_legend(override.aes = list(linetype = NA)),+ #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout |
|||
| 757 | -3x | +|||
| 18 | +
- fill = ggplot2::guide_legend(override.aes = list(shape = NA))+ #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would |
|||
| 758 | +19 |
- )+ #' like to show all occurrences. |
||
| 759 | +20 |
- }+ #' |
||
| 760 | +21 |
-
+ #' @examples |
||
| 761 | -3x | +|||
| 22 | +
- if (!is.null(max_time) && !is.null(xticks)) {
+ #' library(dplyr) |
|||
| 762 | -! | +|||
| 23 | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))))+ #' df <- data.frame( |
|||
| 763 | -3x | +|||
| 24 | +
- } else if (!is.null(xticks)) {
+ #' USUBJID = as.character(c( |
|||
| 764 | -3x | +|||
| 25 | +
- if (max(data$time) <= max(xticks)) {
+ #' 1, 1, 2, 4, 4, 4, |
|||
| 765 | -2x | +|||
| 26 | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)))+ #' 6, 6, 6, 7, 7, 8 |
|||
| 766 | +27 |
- } else {
+ #' )), |
||
| 767 | -1x | +|||
| 28 | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks)+ #' MHDECOD = c( |
|||
| 768 | +29 |
- }+ #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3", |
||
| 769 | -! | +|||
| 30 | +
- } else if (!is.null(max_time)) {
+ #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4" |
|||
| 770 | -! | +|||
| 31 | +
- gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time))+ #' ), |
|||
| 771 | +32 |
- }+ #' ARM = rep(c("A", "B"), each = 6),
|
||
| 772 | +33 |
-
+ #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
|
||
| 773 | -3x | +|||
| 34 | +
- if (!is.null(ggtheme)) {
+ #' ) |
|||
| 774 | -3x | +|||
| 35 | +
- gg <- gg + ggtheme+ #' df_adsl <- df %>% |
|||
| 775 | +36 |
- }+ #' select(USUBJID, ARM) %>% |
||
| 776 | +37 |
-
+ #' unique() |
||
| 777 | -3x | +|||
| 38 | +
- gg + ggplot2::theme(+ #' |
|||
| 778 | -3x | +|||
| 39 | +
- legend.position = "bottom",+ #' @name count_occurrences |
|||
| 779 | -3x | +|||
| 40 | +
- legend.title = ggplot2::element_blank(),+ #' @order 1 |
|||
| 780 | -3x | +|||
| 41 | +
- legend.key.height = unit(0.02, "npc"),+ NULL |
|||
| 781 | -3x | +|||
| 42 | +
- panel.grid.major.x = ggplot2::element_line(linewidth = 2)+ |
|||
| 782 | +43 |
- )+ #' @describeIn count_occurrences Statistics function which counts number of patients that report an |
||
| 783 | +44 |
- }+ #' occurrence. |
||
| 784 | +45 |
-
+ #' |
||
| 785 | +46 |
- #' `ggplot` Decomposition+ #' @param denom (`string`)\cr choice of denominator for patient proportions. Can be: |
||
| 786 | +47 |
- #'+ #' - `N_col`: total number of patients in this column across rows |
||
| 787 | +48 |
- #' @description `r lifecycle::badge("stable")`
+ #' - `n`: number of patients with any occurrences |
||
| 788 | +49 |
#' |
||
| 789 | +50 |
- #' The elements composing the `ggplot` are extracted and organized in a `list`.+ #' @return |
||
| 790 | +51 |
- #'+ #' * `s_count_occurrences()` returns a list with: |
||
| 791 | +52 |
- #' @param gg (`ggplot`)\cr a graphic to decompose.+ #' * `count`: list of counts with one element per occurrence. |
||
| 792 | +53 |
- #'+ #' * `count_fraction`: list of counts and fractions with one element per occurrence. |
||
| 793 | +54 |
- #' @return A named `list` with elements:+ #' * `fraction`: list of numerators and denominators with one element per occurrence. |
||
| 794 | +55 |
- #' * `panel`: The panel.+ #' |
||
| 795 | +56 |
- #' * `yaxis`: The y-axis.+ #' @examples |
||
| 796 | +57 |
- #' * `xaxis`: The x-axis.+ #' # Count unique occurrences per subject. |
||
| 797 | +58 |
- #' * `xlab`: The x-axis label.+ #' s_count_occurrences( |
||
| 798 | +59 |
- #' * `ylab`: The y-axis label.+ #' df, |
||
| 799 | +60 | ++ |
+ #' .N_col = 4L,+ |
+ |
| 61 |
- #' * `guide`: The legend.+ #' .df_row = df, |
|||
| 800 | +62 |
- #'+ #' .var = "MHDECOD", |
||
| 801 | +63 |
- #' @examples+ #' id = "USUBJID" |
||
| 802 | +64 |
- #' \donttest{
+ #' ) |
||
| 803 | +65 |
- #' library(dplyr)+ #' |
||
| 804 | +66 |
- #' library(survival)+ #' @export |
||
| 805 | +67 |
- #' library(grid)+ s_count_occurrences <- function(df, |
||
| 806 | +68 |
- #'+ denom = c("N_col", "n"),
|
||
| 807 | +69 |
- #' fit_km <- tern_ex_adtte %>%+ .N_col, # nolint |
||
| 808 | +70 |
- #' filter(PARAMCD == "OS") %>%+ .df_row, |
||
| 809 | +71 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ drop = TRUE, |
||
| 810 | +72 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ .var = "MHDECOD", |
||
| 811 | +73 |
- #' xticks <- h_xticks(data = data_plot)+ id = "USUBJID") {
|
||
| 812 | -+ | |||
| 74 | +57x |
- #' gg <- h_ggkm(+ checkmate::assert_flag(drop) |
||
| 813 | -+ | |||
| 75 | +57x |
- #' data = data_plot,+ assert_df_with_variables(df, list(range = .var, id = id)) |
||
| 814 | -+ | |||
| 76 | +57x |
- #' yval = "Survival",+ checkmate::assert_count(.N_col) |
||
| 815 | -+ | |||
| 77 | +57x |
- #' censor_show = TRUE,+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
||
| 816 | -+ | |||
| 78 | +57x |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
|
||
| 817 | -+ | |||
| 79 | +57x |
- #' title = "tt",+ denom <- match.arg(denom) |
||
| 818 | +80 |
- #' footnotes = "ff"+ |
||
| 819 | -+ | |||
| 81 | +57x |
- #' )+ occurrences <- if (drop) {
|
||
| 820 | +82 |
- #'+ # Note that we don't try to preserve original level order here since a) that would required |
||
| 821 | +83 |
- #' g_el <- h_decompose_gg(gg)+ # more time to look up in large original levels and b) that would fail for character input variable. |
||
| 822 | -+ | |||
| 84 | +46x |
- #' grid::grid.newpage()+ occurrence_levels <- sort(unique(.df_row[[.var]])) |
||
| 823 | -+ | |||
| 85 | +46x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5))+ if (length(occurrence_levels) == 0) {
|
||
| 824 | -+ | |||
| 86 | +1x |
- #' grid::grid.draw(g_el$panel)+ stop( |
||
| 825 | -+ | |||
| 87 | +1x |
- #'+ "no empty `.df_row` input allowed when `drop = TRUE`,", |
||
| 826 | -+ | |||
| 88 | +1x |
- #' grid::grid.newpage()+ " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls" |
||
| 827 | +89 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5))+ ) |
||
| 828 | +90 |
- #' grid::grid.draw(with(g_el, cbind(ylab, yaxis)))+ } |
||
| 829 | -+ | |||
| 91 | +45x |
- #' }+ factor(df[[.var]], levels = occurrence_levels) |
||
| 830 | +92 |
- #'+ } else {
|
||
| 831 | -+ | |||
| 93 | +11x |
- #' @export+ df[[.var]] |
||
| 832 | +94 |
- h_decompose_gg <- function(gg) {
+ } |
||
| 833 | -3x | +95 | +56x |
- g_el <- ggplot2::ggplotGrob(gg)+ ids <- factor(df[[id]]) |
| 834 | -3x | +96 | +56x |
- y <- c(+ dn <- switch(denom, |
| 835 | -3x | +97 | +56x |
- panel = "panel",+ n = nlevels(ids), |
| 836 | -3x | +98 | +56x |
- yaxis = "axis-l",+ N_col = .N_col |
| 837 | -3x | +|||
| 99 | +
- xaxis = "axis-b",+ ) |
|||
| 838 | -3x | +100 | +56x |
- xlab = "xlab-b",+ has_occurrence_per_id <- table(occurrences, ids) > 0 |
| 839 | -3x | +101 | +56x |
- ylab = "ylab-l",+ n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id)) |
| 840 | -3x | +102 | +56x |
- guide = "guide"+ list( |
| 841 | -+ | |||
| 103 | +56x |
- )+ count = n_ids_per_occurrence, |
||
| 842 | -3x | +104 | +56x |
- lapply(X = y, function(x) gtable::gtable_filter(g_el, x))+ count_fraction = lapply( |
| 843 | -+ | |||
| 105 | +56x |
- }+ n_ids_per_occurrence, |
||
| 844 | -+ | |||
| 106 | +56x |
-
+ function(i, denom) {
|
||
| 845 | -+ | |||
| 107 | +202x |
- #' Helper: KM Layout+ if (i == 0 && denom == 0) {
|
||
| 846 | -+ | |||
| 108 | +! |
- #'+ c(0, 0) |
||
| 847 | +109 |
- #' @description `r lifecycle::badge("stable")`
+ } else {
|
||
| 848 | -+ | |||
| 110 | +202x |
- #'+ c(i, i / denom) |
||
| 849 | +111 |
- #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve.+ } |
||
| 850 | +112 |
- #'+ }, |
||
| 851 | -+ | |||
| 113 | +56x |
- #' @inheritParams g_km+ denom = dn |
||
| 852 | +114 |
- #' @inheritParams h_ggkm+ ), |
||
| 853 | -+ | |||
| 115 | +56x |
- #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`.+ fraction = lapply( |
||
| 854 | -+ | |||
| 116 | +56x |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of+ n_ids_per_occurrence, |
||
| 855 | -+ | |||
| 117 | +56x |
- #' patient at risk matching the main grid of the Kaplan-Meier curve.+ function(i, denom) c("num" = i, "denom" = denom),
|
||
| 856 | -+ | |||
| 118 | +56x |
- #'+ denom = dn |
||
| 857 | +119 |
- #' @return A grid layout.+ ) |
||
| 858 | +120 |
- #'+ ) |
||
| 859 | +121 |
- #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the+ } |
||
| 860 | +122 |
- #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space.+ |
||
| 861 | +123 |
- #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient+ #' @describeIn count_occurrences Formatted analysis function which is used as `afun` |
||
| 862 | +124 |
- #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of+ #' in `count_occurrences()`. |
||
| 863 | +125 |
- #' the strata name.+ #' |
||
| 864 | +126 |
- #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table.+ #' @return |
||
| 865 | +127 |
- #'+ #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 866 | +128 |
- #' @examples+ #' |
||
| 867 | +129 |
- #' \donttest{
+ #' @examples |
||
| 868 | +130 |
- #' library(dplyr)+ #' a_count_occurrences( |
||
| 869 | +131 |
- #' library(survival)+ #' df, |
||
| 870 | +132 |
- #' library(grid)+ #' .N_col = 4L, |
||
| 871 | +133 |
- #'+ #' .df_row = df, |
||
| 872 | +134 |
- #' fit_km <- tern_ex_adtte %>%+ #' .var = "MHDECOD", |
||
| 873 | +135 |
- #' filter(PARAMCD == "OS") %>%+ #' id = "USUBJID" |
||
| 874 | +136 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' ) |
||
| 875 | +137 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' |
||
| 876 | +138 |
- #' xticks <- h_xticks(data = data_plot)+ #' @export |
||
| 877 | +139 |
- #' gg <- h_ggkm(+ a_count_occurrences <- function(df, |
||
| 878 | +140 |
- #' data = data_plot,+ labelstr = "", |
||
| 879 | +141 |
- #' censor_show = TRUE,+ id = "USUBJID", |
||
| 880 | +142 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ denom = c("N_col", "n"),
|
||
| 881 | +143 |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ drop = TRUE, |
||
| 882 | +144 |
- #' )+ .N_col, # nolint |
||
| 883 | +145 |
- #' g_el <- h_decompose_gg(gg)+ .var = NULL, |
||
| 884 | +146 |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ .df_row = NULL, |
||
| 885 | +147 |
- #' grid.show.layout(lyt)+ .stats = NULL, |
||
| 886 | +148 |
- #' }+ .formats = NULL, |
||
| 887 | +149 |
- #'+ .labels = NULL, |
||
| 888 | +150 |
- #' @export+ .indent_mods = NULL, |
||
| 889 | +151 |
- h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
- |
- ||
| 890 | -2x | -
- txtlines <- levels(as.factor(data$strata))- |
- ||
| 891 | -2x | -
- nlines <- nlevels(as.factor(data$strata))+ na_str = default_na_str()) {
|
||
| 892 | -2x | +152 | +46x |
- col_annot_width <- max(+ denom <- match.arg(denom) |
| 893 | -2x | +153 | +46x |
- c(+ x_stats <- s_count_occurrences( |
| 894 | -2x | +154 | +46x |
- as.numeric(grid::convertX(g_el$yaxis$width + g_el$ylab$width, "pt")),+ df = df, denom = denom, .N_col = .N_col, .df_row = .df_row, drop = drop, .var = .var, id = id |
| 895 | -2x | +|||
| 155 | +
- as.numeric(+ ) |
|||
| 896 | -2x | +156 | +46x |
- grid::convertX(+ if (is.null(unlist(x_stats))) {
|
| 897 | -2x | -
- grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt"- |
- ||
| 898 | -+ | 157 | +3x |
- )+ return(NULL) |
| 899 | +158 |
- )+ } |
||
| 900 | -+ | |||
| 159 | +43x |
- )+ x_lvls <- names(x_stats[[1]]) |
||
| 901 | +160 |
- )+ |
||
| 902 | +161 | - - | -||
| 903 | -2x | -
- ttl_row <- as.numeric(!is.null(title))+ # Fill in with formatting defaults if needed |
||
| 904 | -2x | +162 | +43x |
- foot_row <- as.numeric(!is.null(footnotes))+ .stats <- get_stats("count_occurrences", stats_in = .stats)
|
| 905 | -2x | +163 | +43x |
- no_tbl_ind <- c()+ .formats <- get_formats_from_stats(.stats, .formats) |
| 906 | -2x | +164 | +43x |
- ht_x <- c()+ .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls) |
| 907 | -2x | +165 | +43x |
- ht_units <- c()+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls) |
| 908 | +166 | |||
| 909 | -2x | -
- if (ttl_row == 1) {
- |
- ||
| 910 | -1x | -
- no_tbl_ind <- c(no_tbl_ind, TRUE)- |
- ||
| 911 | -1x | +167 | +42x |
- ht_x <- c(ht_x, 2)+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
| 912 | -1x | +168 | +43x |
- ht_units <- c(ht_units, "lines")+ x_stats <- x_stats[.stats] |
| 913 | +169 |
- }+ |
||
| 914 | +170 | - - | -||
| 915 | -2x | -
- no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2))- |
- ||
| 916 | -2x | -
- ht_x <- c(- |
- ||
| 917 | -2x | -
- ht_x,+ # Ungroup statistics with values for each level of x |
||
| 918 | -2x | +171 | +43x |
- 1,+ x_ungrp <- ungroup_stats(x_stats, .formats, list(), list()) |
| 919 | -2x | +172 | +43x |
- grid::convertX(with(g_el, xaxis$height + ylab$width), "pt") + grid::unit(5, "pt"),+ x_stats <- x_ungrp[["x"]] |
| 920 | -2x | +173 | +43x |
- grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"),+ .formats <- x_ungrp[[".formats"]] |
| 921 | -2x | +|||
| 174 | +
- 1,+ |
|||
| 922 | -2x | +|||
| 175 | +
- nlines + 0.5,+ # Auto format handling |
|||
| 923 | -2x | +176 | +43x |
- grid::convertX(with(g_el, xaxis$height + ylab$width), "pt")+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
| 924 | +177 |
- )- |
- ||
| 925 | -2x | -
- ht_units <- c(+ |
||
| 926 | -2x | +178 | +43x |
- ht_units,+ in_rows( |
| 927 | -2x | +179 | +43x |
- "null",+ .list = x_stats, |
| 928 | -2x | +180 | +43x |
- "pt",+ .formats = .formats, |
| 929 | -2x | +181 | +43x |
- "pt",+ .names = .labels, |
| 930 | -2x | +182 | +43x |
- "lines",+ .labels = .labels, |
| 931 | -2x | +183 | +43x |
- "lines",+ .indent_mods = .indent_mods, |
| 932 | -2x | +184 | +43x |
- "pt"+ .format_na_strs = na_str |
| 933 | +185 |
) |
||
| 934 | +186 |
-
+ } |
||
| 935 | -2x | +|||
| 187 | +
- if (foot_row == 1) {
+
|
|||
| 936 | -1x | +|||
| 188 | +
- no_tbl_ind <- c(no_tbl_ind, TRUE)+ #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments |
|||
| 937 | -1x | +|||
| 189 | +
- ht_x <- c(ht_x, 1)+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 938 | -1x | +|||
| 190 | +
- ht_units <- c(ht_units, "lines")+ #' |
|||
| 939 | +191 |
- }+ #' @return |
||
| 940 | -2x | +|||
| 192 | +
- if (annot_at_risk) {
+ #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions, |
|||
| 941 | -2x | +|||
| 193 | +
- no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 942 | -2x | +|||
| 194 | +
- if (!annot_at_risk_title) {
+ #' the statistics from `s_count_occurrences()` to the table layout. |
|||
| 943 | -! | +|||
| 195 | +
- no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE+ #' |
|||
| 944 | +196 |
- }+ #' @examples |
||
| 945 | +197 |
- } else {
+ #' # Create table layout |
||
| 946 | -! | +|||
| 198 | +
- no_at_risk_tbl <- no_tbl_ind+ #' lyt <- basic_table() %>% |
|||
| 947 | +199 |
- }+ #' split_cols_by("ARM") %>%
|
||
| 948 | +200 |
-
+ #' add_colcounts() %>% |
||
| 949 | -2x | +|||
| 201 | +
- grid::grid.layout(+ #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
|
|||
| 950 | -2x | +|||
| 202 | +
- nrow = sum(no_at_risk_tbl), ncol = 2,+ #' |
|||
| 951 | -2x | +|||
| 203 | +
- widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
+ #' # Apply table layout to data and produce `rtable` object |
|||
| 952 | -2x | +|||
| 204 | +
- heights = grid::unit(+ #' tbl <- lyt %>% |
|||
| 953 | -2x | +|||
| 205 | +
- x = ht_x[no_at_risk_tbl],+ #' build_table(df, alt_counts_df = df_adsl) %>% |
|||
| 954 | -2x | +|||
| 206 | +
- units = ht_units[no_at_risk_tbl]+ #' prune_table() |
|||
| 955 | +207 |
- )+ #' |
||
| 956 | +208 |
- )+ #' tbl |
||
| 957 | +209 |
- }+ #' |
||
| 958 | +210 |
-
+ #' @export |
||
| 959 | +211 |
- #' Helper: Patient-at-Risk Grobs+ #' @order 2 |
||
| 960 | +212 |
- #'+ count_occurrences <- function(lyt, |
||
| 961 | +213 |
- #' @description `r lifecycle::badge("stable")`
+ vars, |
||
| 962 | +214 |
- #'+ id = "USUBJID", |
||
| 963 | +215 |
- #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of+ drop = TRUE, |
||
| 964 | +216 |
- #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is+ var_labels = vars, |
||
| 965 | +217 |
- #' also obtained.+ show_labels = "hidden", |
||
| 966 | +218 |
- #'+ riskdiff = FALSE, |
||
| 967 | +219 |
- #' @inheritParams g_km+ na_str = default_na_str(), |
||
| 968 | +220 |
- #' @inheritParams h_ggkm+ nested = TRUE, |
||
| 969 | +221 |
- #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which+ ..., |
||
| 970 | +222 |
- #' includes the number of patients at risk at given time points.+ table_names = vars, |
||
| 971 | +223 |
- #' @param xlim (`numeric`)\cr the maximum value on the x-axis (used to+ .stats = "count_fraction_fixed_dp", |
||
| 972 | +224 |
- #' ensure the at risk table aligns with the KM graph).+ .formats = NULL, |
||
| 973 | +225 |
- #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ .labels = NULL, |
||
| 974 | +226 |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ .indent_mods = NULL) {
|
||
| 975 | -+ | |||
| 227 | +7x |
- #'+ checkmate::assert_flag(riskdiff) |
||
| 976 | +228 |
- #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three+ |
||
| 977 | -+ | |||
| 229 | +7x |
- #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`.+ extra_args <- list( |
||
| 978 | -+ | |||
| 230 | +7x |
- #'+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
||
| 979 | +231 |
- #' @examples+ ) |
||
| 980 | -+ | |||
| 232 | +7x |
- #' \donttest{
+ s_args <- list(id = id, drop = drop, ...) |
||
| 981 | +233 |
- #' library(dplyr)+ |
||
| 982 | -+ | |||
| 234 | +7x |
- #' library(survival)+ if (isFALSE(riskdiff)) {
|
||
| 983 | -+ | |||
| 235 | +6x |
- #' library(grid)+ extra_args <- c(extra_args, s_args) |
||
| 984 | +236 |
- #'+ } else {
|
||
| 985 | -+ | |||
| 237 | +1x |
- #' fit_km <- tern_ex_adtte %>%+ extra_args <- c( |
||
| 986 | -+ | |||
| 238 | +1x |
- #' filter(PARAMCD == "OS") %>%+ extra_args, |
||
| 987 | -+ | |||
| 239 | +1x |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ list( |
||
| 988 | -+ | |||
| 240 | +1x |
- #'+ afun = list("s_count_occurrences" = a_count_occurrences),
|
||
| 989 | -+ | |||
| 241 | +1x |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ s_args = s_args |
||
| 990 | +242 |
- #'+ ) |
||
| 991 | +243 |
- #' xticks <- h_xticks(data = data_plot)+ ) |
||
| 992 | +244 |
- #'+ } |
||
| 993 | +245 |
- #' gg <- h_ggkm(+ |
||
| 994 | -+ | |||
| 246 | +7x |
- #' data = data_plot,+ analyze( |
||
| 995 | -+ | |||
| 247 | +7x |
- #' censor_show = TRUE,+ lyt = lyt, |
||
| 996 | -+ | |||
| 248 | +7x |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ vars = vars, |
||
| 997 | -+ | |||
| 249 | +7x |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff), |
||
| 998 | -+ | |||
| 250 | +7x |
- #' )+ var_labels = var_labels, |
||
| 999 | -+ | |||
| 251 | +7x |
- #'+ show_labels = show_labels, |
||
| 1000 | -+ | |||
| 252 | +7x |
- #' # The annotation table reports the patient at risk for a given strata and+ table_names = table_names, |
||
| 1001 | -+ | |||
| 253 | +7x |
- #' # time (`xticks`).+ na_str = na_str, |
||
| 1002 | -+ | |||
| 254 | +7x |
- #' annot_tbl <- summary(fit_km, time = xticks)+ nested = nested, |
||
| 1003 | -+ | |||
| 255 | +7x |
- #' if (is.null(fit_km$strata)) {
+ extra_args = extra_args |
||
| 1004 | +256 |
- #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All"))+ ) |
||
| 1005 | +257 |
- #' } else {
+ } |
||
| 1006 | +258 |
- #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+
|
||
| 1007 | +259 |
- #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ #' @describeIn count_occurrences Layout-creating function which can take content function arguments |
||
| 1008 | +260 |
- #' annot_tbl <- data.frame(+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 1009 | +261 |
- #' n.risk = annot_tbl$n.risk,+ #' |
||
| 1010 | +262 |
- #' time = annot_tbl$time,+ #' @return |
||
| 1011 | +263 |
- #' strata = annot_tbl$strata+ #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions, |
||
| 1012 | +264 |
- #' )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 1013 | +265 |
- #' }+ #' containing the statistics from `s_count_occurrences()` to the table layout. |
||
| 1014 | +266 |
#' |
||
| 1015 | +267 |
- #' # The annotation table is transformed into a grob.+ #' @examples |
||
| 1016 | +268 |
- #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks))+ #' # Layout creating function with custom format. |
||
| 1017 | +269 |
- #'+ #' basic_table() %>% |
||
| 1018 | +270 |
- #' # For the representation, the layout is estimated for which the decomposition+ #' add_colcounts() %>% |
||
| 1019 | +271 |
- #' # of the graphic element is necessary.+ #' split_rows_by("SEX", child_labels = "visible") %>%
|
||
| 1020 | +272 |
- #' g_el <- h_decompose_gg(gg)+ #' summarize_occurrences( |
||
| 1021 | +273 |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ #' var = "MHDECOD", |
||
| 1022 | +274 |
- #'+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 1023 | +275 |
- #' grid::grid.newpage()+ #' ) %>% |
||
| 1024 | +276 |
- #' pushViewport(viewport(layout = lyt, height = .95, width = .95))+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 1025 | +277 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1))+ #' |
||
| 1026 | +278 |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2))+ #' @export |
||
| 1027 | +279 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1))+ #' @order 3 |
||
| 1028 | +280 |
- #' grid::grid.draw(tbl$at_risk)+ summarize_occurrences <- function(lyt, |
||
| 1029 | +281 |
- #' popViewport()+ var, |
||
| 1030 | +282 |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1))+ id = "USUBJID", |
||
| 1031 | +283 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1))+ drop = TRUE, |
||
| 1032 | +284 |
- #' grid::grid.draw(tbl$label)+ riskdiff = FALSE, |
||
| 1033 | +285 |
- #' }+ na_str = default_na_str(), |
||
| 1034 | +286 |
- #'+ ..., |
||
| 1035 | +287 |
- #' @export+ .stats = "count_fraction_fixed_dp", |
||
| 1036 | +288 |
- h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
+ .formats = NULL, |
||
| 1037 | -2x | +|||
| 289 | +
- txtlines <- levels(as.factor(data$strata))+ .indent_mods = NULL, |
|||
| 1038 | -2x | +|||
| 290 | +
- nlines <- nlevels(as.factor(data$strata))+ .labels = NULL) {
|
|||
| 1039 | +291 | 2x |
- y_int <- annot_tbl$time[2] - annot_tbl$time[1]+ checkmate::assert_flag(riskdiff) |
|
| 1040 | -2x | +|||
| 292 | +
- annot_tbl <- expand.grid(+ |
|||
| 1041 | +293 | 2x |
- time = seq(0, xlim, y_int),+ extra_args <- list( |
|
| 1042 | +294 | 2x |
- strata = unique(annot_tbl$strata)+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
|
| 1043 | -2x | +|||
| 295 | +
- ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
+ ) |
|||
| 1044 | +296 | 2x |
- annot_tbl[is.na(annot_tbl)] <- 0+ s_args <- list(id = id, drop = drop, ...) |
|
| 1045 | -2x | +|||
| 297 | +
- y_str_unit <- as.numeric(annot_tbl$strata)+ |
|||
| 1046 | +298 | 2x |
- vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines"))+ if (isFALSE(riskdiff)) {
|
|
| 1047 | -2x | +299 | +1x |
- if (title) {
+ extra_args <- c(extra_args, s_args) |
| 1048 | -2x | +|||
| 300 | +
- gb_table_title <- grid::gList(+ } else {
|
|||
| 1049 | -2x | +301 | +1x |
- grid::textGrob(+ extra_args <- c( |
| 1050 | -2x | +302 | +1x |
- label = "Patients at Risk:",+ extra_args, |
| 1051 | -2x | +303 | +1x |
- x = 1,+ list( |
| 1052 | -2x | +304 | +1x |
- y = grid::unit(0.2, "native"),+ afun = list("s_count_occurrences" = a_count_occurrences),
|
| 1053 | -2x | +305 | +1x |
- gp = grid::gpar(fontface = "bold", fontsize = 10)+ s_args = s_args |
| 1054 | +306 |
) |
||
| 1055 | +307 |
) |
||
| 1056 | +308 |
} |
||
| 1057 | -2x | +|||
| 309 | +
- gb_table_left_annot <- grid::gList(+ |
|||
| 1058 | +310 | 2x |
- grid::rectGrob(+ summarize_row_groups( |
|
| 1059 | +311 | 2x |
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ lyt = lyt, |
|
| 1060 | +312 | 2x |
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ var = var, |
|
| 1061 | +313 | 2x |
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff), |
|
| 1062 | -+ | |||
| 314 | +2x |
- ),+ na_str = na_str, |
||
| 1063 | +315 | 2x |
- grid::textGrob(+ extra_args = extra_args |
|
| 1064 | -2x | +|||
| 316 | +
- label = unique(annot_tbl$strata),+ ) |
|||
| 1065 | -2x | +|||
| 317 | +
- x = 0.5,+ } |
|||
| 1066 | -2x | +
| 1 | +
- y = grid::unit(+ #' Summary numeric variables in columns |
|||
| 1067 | -2x | +|||
| 2 | +
- (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75,+ #' |
|||
| 1068 | -2x | +|||
| 3 | +
- "native"+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 1069 | +4 |
- ),+ #' |
||
| 1070 | -2x | +|||
| 5 | +
- gp = grid::gpar(fontface = "italic", fontsize = 10)+ #' Layout-creating function which can be used for creating column-wise summary tables. |
|||
| 1071 | +6 |
- )+ #' This function sets the analysis methods as column labels and is a wrapper for |
||
| 1072 | +7 |
- )+ #' [rtables::analyze_colvars()]. It was designed principally for PK tables. |
||
| 1073 | -2x | +|||
| 8 | +
- gb_patient_at_risk <- grid::gList(+ #' |
|||
| 1074 | -2x | +|||
| 9 | +
- grid::rectGrob(+ #' @inheritParams argument_convention |
|||
| 1075 | -2x | +|||
| 10 | +
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ #' @inheritParams rtables::analyze_colvars |
|||
| 1076 | -2x | +|||
| 11 | +
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ #' @param imp_rule (`character`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can |
|||
| 1077 | -2x | +|||
| 12 | +
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order |
|||
| 1078 | +13 |
- ),+ #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()] |
||
| 1079 | -2x | +|||
| 14 | +
- grid::textGrob(+ #' for more details on imputation. |
|||
| 1080 | -2x | +|||
| 15 | +
- label = annot_tbl$n.risk,+ #' @param avalcat_var (`character`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a |
|||
| 1081 | -2x | +|||
| 16 | +
- x = grid::unit(annot_tbl$time, "native"),+ #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of |
|||
| 1082 | -2x | +|||
| 17 | +
- y = grid::unit(+ #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable |
|||
| 1083 | -2x | +|||
| 18 | +
- (max(y_str_unit) - y_str_unit) + .5,+ #' used to calculate the `n_blq` statistic (if included in `.stats`). |
|||
| 1084 | -2x | +|||
| 19 | +
- "line"+ #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will |
|||
| 1085 | -2x | +|||
| 20 | +
- ) # maybe native+ #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is |
|||
| 1086 | +21 |
- )+ #' used for multiple tables with different data. Defaults to `FALSE`. |
||
| 1087 | +22 |
- )+ #' @param row_labels (`character`)\cr as this function works in columns space, usual `.labels` |
||
| 1088 | +23 |
-
+ #' character vector applies on the column space. You can change the row labels by defining this |
||
| 1089 | -2x | +|||
| 24 | +
- ret <- list(+ #' parameter to a named character vector with names corresponding to the split values. It defaults |
|||
| 1090 | -2x | +|||
| 25 | +
- at_risk = grid::gList(+ #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label. |
|||
| 1091 | -2x | +|||
| 26 | +
- grid::gTree(+ #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current |
|||
| 1092 | -2x | +|||
| 27 | +
- vp = vp_table,+ #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr` |
|||
| 1093 | -2x | +|||
| 28 | +
- children = grid::gList(+ #' to define row labels. This behavior is not supported as we never need to overload row labels. |
|||
| 1094 | -2x | +|||
| 29 | +
- grid::gTree(+ #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns. |
|||
| 1095 | -2x | +|||
| 30 | +
- vp = grid::dataViewport(+ #' This option allows you to add multiple instances of this functions, also in a nested fashion, |
|||
| 1096 | -2x | +|||
| 31 | +
- xscale = c(0, xlim) + c(-0.05, 0.05) * xlim,+ #' without adding more splits. This split must happen only one time on a single layout. |
|||
| 1097 | -2x | +|||
| 32 | +
- yscale = c(0, nlines + 1),+ #' |
|||
| 1098 | -2x | +|||
| 33 | +
- extension = c(0.05, 0)+ #' @return |
|||
| 1099 | +34 |
- ),+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 1100 | -2x | +|||
| 35 | +
- children = grid::gList(gb_patient_at_risk)+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
|||
| 1101 | +36 |
- )+ #' in columns, and add it to the table layout. |
||
| 1102 | +37 |
- )+ #' |
||
| 1103 | +38 |
- )+ #' @note This is an experimental implementation of [rtables::summarize_row_groups()] and |
||
| 1104 | +39 |
- ),+ #' [rtables::analyze_colvars()] that may be subjected to changes as `rtables` extends its |
||
| 1105 | -2x | +|||
| 40 | +
- label = grid::gList(+ #' support to more complex analysis pipelines on the column space. For the same reasons, |
|||
| 1106 | -2x | +|||
| 41 | +
- grid::gTree(+ #' we encourage to read the examples carefully and file issues for cases that differ from |
|||
| 1107 | -2x | +|||
| 42 | +
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ #' them. |
|||
| 1108 | -2x | +|||
| 43 | +
- children = grid::gList(+ #' |
|||
| 1109 | -2x | +|||
| 44 | +
- grid::gTree(+ #' Here `labelstr` behaves differently than usual. If it is not defined (default as `NULL`), |
|||
| 1110 | -2x | +|||
| 45 | +
- vp = grid::dataViewport(+ #' row labels are assigned automatically to the split values in case of `rtables::analyze_colvars` |
|||
| 1111 | -2x | +|||
| 46 | +
- xscale = 0:1,+ #' (`do_summarize_row_groups = FALSE`, the default), and to the group label for |
|||
| 1112 | -2x | +|||
| 47 | +
- yscale = c(0, nlines + 1),+ #' `do_summarize_row_groups = TRUE`. |
|||
| 1113 | -2x | +|||
| 48 | +
- extension = c(0.0, 0)+ #' |
|||
| 1114 | +49 |
- ),+ #' @seealso [analyze_vars()], [rtables::analyze_colvars()]. |
||
| 1115 | -2x | +|||
| 50 | +
- children = grid::gList(gb_table_left_annot)+ #' |
|||
| 1116 | +51 |
- )+ #' @examples |
||
| 1117 | +52 |
- )+ #' library(dplyr) |
||
| 1118 | +53 |
- )+ #' |
||
| 1119 | +54 |
- )+ #' # Data preparation |
||
| 1120 | +55 |
- )+ #' adpp <- tern_ex_adpp %>% h_pkparam_sort() |
||
| 1121 | +56 |
-
+ #' |
||
| 1122 | -2x | +|||
| 57 | +
- if (title) {
+ #' lyt <- basic_table() %>% |
|||
| 1123 | -2x | +|||
| 58 | +
- ret[["title"]] <- grid::gList(+ #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>% |
|||
| 1124 | -2x | +|||
| 59 | +
- grid::gTree(+ #' split_rows_by( |
|||
| 1125 | -2x | +|||
| 60 | +
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ #' var = "SEX", |
|||
| 1126 | -2x | +|||
| 61 | +
- children = grid::gList(+ #' label_pos = "topleft", |
|||
| 1127 | -2x | +|||
| 62 | +
- grid::gTree(+ #' child_label = "hidden" |
|||
| 1128 | -2x | +|||
| 63 | +
- vp = grid::dataViewport(+ #' ) %>% # Removes duplicated labels |
|||
| 1129 | -2x | +|||
| 64 | +
- xscale = 0:1,+ #' analyze_vars_in_cols(vars = "AGE") |
|||
| 1130 | -2x | +|||
| 65 | +
- yscale = c(0, 1),+ #' result <- build_table(lyt = lyt, df = adpp) |
|||
| 1131 | -2x | +|||
| 66 | +
- extension = c(0, 0)+ #' result |
|||
| 1132 | +67 |
- ),+ #' |
||
| 1133 | -2x | +|||
| 68 | +
- children = grid::gList(gb_table_title)+ #' # By selecting just some statistics and ad-hoc labels |
|||
| 1134 | +69 |
- )+ #' lyt <- basic_table() %>% |
||
| 1135 | +70 |
- )+ #' split_rows_by(var = "ARM", label_pos = "topleft") %>% |
||
| 1136 | +71 |
- )+ #' split_rows_by( |
||
| 1137 | +72 |
- )+ #' var = "SEX", |
||
| 1138 | +73 |
- }+ #' label_pos = "topleft", |
||
| 1139 | +74 |
-
+ #' child_labels = "hidden", |
||
| 1140 | -2x | +|||
| 75 | +
- ret+ #' split_fun = drop_split_levels |
|||
| 1141 | +76 |
- }+ #' ) %>% |
||
| 1142 | +77 |
-
+ #' analyze_vars_in_cols( |
||
| 1143 | +78 |
- #' Helper Function: Survival Estimations+ #' vars = "AGE", |
||
| 1144 | +79 |
- #'+ #' .stats = c("n", "cv", "geom_mean"),
|
||
| 1145 | +80 |
- #' @description `r lifecycle::badge("stable")`
+ #' .labels = c( |
||
| 1146 | +81 |
- #'+ #' n = "aN", |
||
| 1147 | +82 |
- #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval.+ #' cv = "aCV", |
||
| 1148 | +83 |
- #'+ #' geom_mean = "aGeomMean" |
||
| 1149 | +84 |
- #' @inheritParams h_data_plot+ #' ) |
||
| 1150 | +85 |
- #'+ #' ) |
||
| 1151 | +86 |
- #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ #' result <- build_table(lyt = lyt, df = adpp) |
||
| 1152 | +87 |
- #'+ #' result |
||
| 1153 | +88 |
- #' @examples+ #' |
||
| 1154 | +89 |
- #' \donttest{
+ #' # Changing row labels |
||
| 1155 | +90 |
- #' library(dplyr)+ #' lyt <- basic_table() %>% |
||
| 1156 | +91 |
- #' library(survival)+ #' analyze_vars_in_cols( |
||
| 1157 | +92 |
- #'+ #' vars = "AGE", |
||
| 1158 | +93 |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS")+ #' row_labels = "some custom label" |
||
| 1159 | +94 |
- #' fit <- survfit(+ #' ) |
||
| 1160 | +95 |
- #' form = Surv(AVAL, 1 - CNSR) ~ ARMCD,+ #' result <- build_table(lyt, df = adpp) |
||
| 1161 | +96 |
- #' data = adtte+ #' result |
||
| 1162 | +97 |
- #' )+ #' |
||
| 1163 | +98 |
- #' h_tbl_median_surv(fit_km = fit)+ #' # Pharmacokinetic parameters |
||
| 1164 | +99 |
- #' }+ #' lyt <- basic_table() %>% |
||
| 1165 | +100 |
- #'+ #' split_rows_by( |
||
| 1166 | +101 |
- #' @export+ #' var = "TLG_DISPLAY", |
||
| 1167 | +102 |
- h_tbl_median_surv <- function(fit_km, armval = "All") {
+ #' split_label = "PK Parameter", |
||
| 1168 | -3x | +|||
| 103 | +
- y <- if (is.null(fit_km$strata)) {
+ #' label_pos = "topleft", |
|||
| 1169 | -! | +|||
| 104 | +
- as.data.frame(t(summary(fit_km)$table), row.names = armval)+ #' child_label = "hidden" |
|||
| 1170 | +105 |
- } else {
+ #' ) %>% |
||
| 1171 | -3x | +|||
| 106 | +
- tbl <- summary(fit_km)$table+ #' analyze_vars_in_cols( |
|||
| 1172 | -3x | +|||
| 107 | +
- rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
+ #' vars = "AVAL" |
|||
| 1173 | -3x | +|||
| 108 | +
- rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2]+ #' ) |
|||
| 1174 | -3x | +|||
| 109 | +
- as.data.frame(tbl)+ #' result <- build_table(lyt, df = adpp) |
|||
| 1175 | +110 |
- }+ #' result |
||
| 1176 | -3x | +|||
| 111 | +
- conf.int <- summary(fit_km)$conf.int # nolint+ #' |
|||
| 1177 | -3x | +|||
| 112 | +
- y$records <- round(y$records)+ #' # Multiple calls (summarize label and analyze underneath) |
|||
| 1178 | -3x | +|||
| 113 | +
- y$median <- signif(y$median, 4)+ #' lyt <- basic_table() %>% |
|||
| 1179 | -3x | +|||
| 114 | +
- y$`CI` <- paste0(+ #' split_rows_by( |
|||
| 1180 | -3x | +|||
| 115 | +
- "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
+ #' var = "TLG_DISPLAY", |
|||
| 1181 | +116 |
- )+ #' split_label = "PK Parameter", |
||
| 1182 | -3x | +|||
| 117 | +
- stats::setNames(+ #' label_pos = "topleft" |
|||
| 1183 | -3x | +|||
| 118 | +
- y[c("records", "median", "CI")],
+ #' ) %>% |
|||
| 1184 | -3x | +|||
| 119 | +
- c("N", "Median", f_conf_level(conf.int))
+ #' analyze_vars_in_cols( |
|||
| 1185 | +120 |
- )+ #' vars = "AVAL", |
||
| 1186 | +121 |
- }+ #' do_summarize_row_groups = TRUE # does a summarize level |
||
| 1187 | +122 |
-
+ #' ) %>% |
||
| 1188 | +123 |
- #' Helper Function: Survival Estimation Grob+ #' split_rows_by("SEX",
|
||
| 1189 | +124 |
- #'+ #' child_label = "hidden", |
||
| 1190 | +125 |
- #' @description `r lifecycle::badge("stable")`
+ #' label_pos = "topleft" |
||
| 1191 | +126 |
- #'+ #' ) %>% |
||
| 1192 | +127 |
- #' The survival fit is transformed in a grob containing a table with groups in+ #' analyze_vars_in_cols( |
||
| 1193 | +128 |
- #' rows characterized by N, median and 95% confidence interval.+ #' vars = "AVAL", |
||
| 1194 | +129 |
- #'+ #' split_col_vars = FALSE # avoids re-splitting the columns |
||
| 1195 | +130 |
- #' @inheritParams g_km+ #' ) |
||
| 1196 | +131 |
- #' @inheritParams h_data_plot+ #' result <- build_table(lyt, df = adpp) |
||
| 1197 | +132 |
- #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()].+ #' result |
||
| 1198 | +133 |
- #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location.+ #' |
||
| 1199 | +134 |
- #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location.+ #' @export |
||
| 1200 | +135 |
- #' @param width (`unit`)\cr width (as a unit) to use when printing the grob.+ analyze_vars_in_cols <- function(lyt, |
||
| 1201 | +136 |
- #'+ vars, |
||
| 1202 | +137 |
- #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ ..., |
||
| 1203 | +138 |
- #'+ .stats = c( |
||
| 1204 | +139 |
- #' @examples+ "n", |
||
| 1205 | +140 |
- #' \donttest{
+ "mean", |
||
| 1206 | +141 |
- #' library(dplyr)+ "sd", |
||
| 1207 | +142 |
- #' library(survival)+ "se", |
||
| 1208 | +143 |
- #' library(grid)+ "cv", |
||
| 1209 | +144 |
- #'+ "geom_cv" |
||
| 1210 | +145 |
- #' grid::grid.newpage()+ ), |
||
| 1211 | +146 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ .labels = c( |
||
| 1212 | +147 |
- #' tern_ex_adtte %>%+ n = "n", |
||
| 1213 | +148 |
- #' filter(PARAMCD == "OS") %>%+ mean = "Mean", |
||
| 1214 | +149 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ sd = "SD", |
||
| 1215 | +150 |
- #' h_grob_median_surv() %>%+ se = "SE", |
||
| 1216 | +151 |
- #' grid::grid.draw()+ cv = "CV (%)", |
||
| 1217 | +152 |
- #' }+ geom_cv = "CV % Geometric Mean" |
||
| 1218 | +153 |
- #'+ ), |
||
| 1219 | +154 |
- #' @export+ row_labels = NULL, |
||
| 1220 | +155 |
- h_grob_median_surv <- function(fit_km,+ do_summarize_row_groups = FALSE, |
||
| 1221 | +156 |
- armval = "All",+ split_col_vars = TRUE, |
||
| 1222 | +157 |
- x = 0.9,+ imp_rule = NULL, |
||
| 1223 | +158 |
- y = 0.9,+ avalcat_var = "AVALCAT1", |
||
| 1224 | +159 |
- width = grid::unit(0.3, "npc"),+ cache = FALSE, |
||
| 1225 | +160 |
- ttheme = gridExtra::ttheme_default()) {
+ .indent_mods = NULL, |
||
| 1226 | -2x | +|||
| 161 | +
- data <- h_tbl_median_surv(fit_km, armval = armval)+ na_level = lifecycle::deprecated(), |
|||
| 1227 | +162 |
-
+ na_str = default_na_str(), |
||
| 1228 | -2x | +|||
| 163 | +
- width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ nested = TRUE, |
|||
| 1229 | -2x | +|||
| 164 | +
- height <- width * (nrow(data) + 1) / 12+ .formats = NULL, |
|||
| 1230 | +165 |
-
+ .aligns = NULL) {
|
||
| 1231 | -2x | +166 | +10x |
- w <- paste(" ", c(
+ extra_args <- list(...) |
| 1232 | -2x | +167 | +10x |
- rownames(data)[which.max(nchar(rownames(data)))],+ if (lifecycle::is_present(na_level)) {
|
| 1233 | -2x | +|||
| 168 | +! |
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ lifecycle::deprecate_warn("0.9.1", "analyze_vars_in_cols(na_level)", "analyze_vars_in_cols(na_str)")
|
||
| 1234 | -+ | |||
| 169 | +! |
- ))+ na_str <- na_level |
||
| 1235 | -2x | +|||
| 170 | +
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ } |
|||
| 1236 | +171 | |||
| 1237 | -2x | +172 | +10x |
- w_txt <- sapply(1:64, function(x) {
+ checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE) |
| 1238 | -128x | +173 | +10x |
- graphics::par(ps = x)+ checkmate::assert_character(row_labels, null.ok = TRUE) |
| 1239 | -128x | -
- graphics::strwidth(w[4], units = "in")- |
- ||
| 1240 | -+ | 174 | +10x |
- })+ checkmate::assert_int(.indent_mods, null.ok = TRUE) |
| 1241 | -2x | -
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])- |
- ||
| 1242 | -+ | 175 | +10x |
-
+ checkmate::assert_flag(nested) |
| 1243 | -2x | +176 | +10x |
- h_txt <- sapply(1:64, function(x) {
+ checkmate::assert_flag(split_col_vars) |
| 1244 | -128x | +177 | +10x |
- graphics::par(ps = x)+ checkmate::assert_flag(do_summarize_row_groups) |
| 1245 | -128x | +|||
| 178 | +
- graphics::strheight(grid::stringHeight("X"), units = "in")
+
|
|||
| 1246 | +179 |
- })+ # Filtering |
||
| 1247 | -2x | -
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])- |
- ||
| 1248 | -+ | 180 | +10x |
-
+ met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
|
| 1249 | -2x | +181 | +10x |
- if (ttheme$core$fg_params$fontsize == 12) {
+ .stats <- get_stats(met_grps, stats_in = .stats) |
| 1250 | -2x | +182 | +10x |
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats) |
| 1251 | -2x | +183 | +10x |
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels) |
| 1252 | -2x | +|||
| 184 | +! |
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ if ("control" %in% names(extra_args)) labels_v <- labels_v %>% labels_use_control(extra_args[["control"]], .labels)
|
||
| 1253 | +185 |
- }+ |
||
| 1254 | +186 |
-
+ # Check for vars in the case that one or more are used |
||
| 1255 | -2x | +187 | +10x |
- gt <- gridExtra::tableGrob(+ if (length(vars) == 1) {
|
| 1256 | -2x | +188 | +7x |
- d = data,+ vars <- rep(vars, length(.stats)) |
| 1257 | -2x | +189 | +3x |
- theme = ttheme+ } else if (length(vars) != length(.stats)) {
|
| 1258 | -+ | |||
| 190 | +1x |
- )+ stop( |
||
| 1259 | -2x | +191 | +1x |
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ "Analyzed variables (vars) does not have the same ", |
| 1260 | -2x | +192 | +1x |
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ "number of elements of specified statistics (.stats)." |
| 1261 | +193 | - - | -||
| 1262 | -2x | -
- vp <- grid::viewport(+ ) |
||
| 1263 | -2x | +|||
| 194 | +
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ } |
|||
| 1264 | -2x | +|||
| 195 | +
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ |
|||
| 1265 | -2x | +196 | +9x |
- height = height,+ if (split_col_vars) {
|
| 1266 | -2x | +|||
| 197 | +
- width = width,+ # Checking there is not a previous identical column split |
|||
| 1267 | -2x | -
- just = c("right", "top")
- |
- ||
| 1268 | -+ | 198 | +8x |
- )+ clyt <- tail(clayout(lyt), 1)[[1]] |
| 1269 | +199 | |||
| 1270 | -2x | +200 | +8x |
- grid::gList(+ dummy_lyt <- split_cols_by_multivar( |
| 1271 | -2x | +201 | +8x |
- grid::gTree(+ lyt = basic_table(), |
| 1272 | -2x | +202 | +8x |
- vp = vp,+ vars = vars, |
| 1273 | -2x | +203 | +8x |
- children = grid::gList(gt)+ varlabels = labels_v |
| 1274 | +204 |
) |
||
| 1275 | +205 |
- )+ |
||
| 1276 | -+ | |||
| 206 | +8x |
- }+ if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
|
||
| 1277 | -+ | |||
| 207 | +! |
-
+ stop( |
||
| 1278 | -+ | |||
| 208 | +! |
- #' Helper: Grid Object with y-axis Annotation+ "Column split called again with the same values. ", |
||
| 1279 | -+ | |||
| 209 | +! |
- #'+ "This can create many unwanted columns. Please consider adding ", |
||
| 1280 | -+ | |||
| 210 | +! |
- #' @description `r lifecycle::badge("stable")`
+ "split_col_vars = FALSE to the last call of ", |
||
| 1281 | -+ | |||
| 211 | +! |
- #'+ deparse(sys.calls()[[sys.nframe() - 1]]), "." |
||
| 1282 | +212 |
- #' Build the y-axis annotation from a decomposed `ggplot`.+ ) |
||
| 1283 | +213 |
- #'+ } |
||
| 1284 | +214 |
- #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`.+ |
||
| 1285 | +215 |
- #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`.+ # Main col split |
||
| 1286 | -+ | |||
| 216 | +8x |
- #'+ lyt <- split_cols_by_multivar( |
||
| 1287 | -+ | |||
| 217 | +8x |
- #' @return a `gTree` object containing the y-axis annotation from a `ggplot`.+ lyt = lyt, |
||
| 1288 | -+ | |||
| 218 | +8x |
- #'+ vars = vars, |
||
| 1289 | -+ | |||
| 219 | +8x |
- #' @examples+ varlabels = labels_v |
||
| 1290 | +220 |
- #' \donttest{
+ ) |
||
| 1291 | +221 |
- #' library(dplyr)+ } |
||
| 1292 | +222 |
- #' library(survival)+ |
||
| 1293 | -+ | |||
| 223 | +9x |
- #' library(grid)+ env <- new.env() # create caching environment |
||
| 1294 | +224 |
- #'+ |
||
| 1295 | -+ | |||
| 225 | +9x |
- #' fit_km <- tern_ex_adtte %>%+ if (do_summarize_row_groups) {
|
||
| 1296 | -+ | |||
| 226 | +2x |
- #' filter(PARAMCD == "OS") %>%+ if (length(unique(vars)) > 1) {
|
||
| 1297 | -+ | |||
| 227 | +! |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ stop("When using do_summarize_row_groups only one label level var should be inserted.")
|
||
| 1298 | +228 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ } |
||
| 1299 | +229 |
- #' xticks <- h_xticks(data = data_plot)+ |
||
| 1300 | +230 |
- #' gg <- h_ggkm(+ # Function list for do_summarize_row_groups. Slightly different handling of labels |
||
| 1301 | -+ | |||
| 231 | +2x |
- #' data = data_plot,+ cfun_list <- Map( |
||
| 1302 | -+ | |||
| 232 | +2x |
- #' censor_show = TRUE,+ function(stat, use_cache, cache_env) {
|
||
| 1303 | -+ | |||
| 233 | +12x |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ function(u, .spl_context, labelstr, .df_row, ...) {
|
||
| 1304 | +234 |
- #' title = "title", footnotes = "footnotes", yval = "Survival"+ # Statistic |
||
| 1305 | -+ | |||
| 235 | +24x |
- #' )+ var_row_val <- paste( |
||
| 1306 | -+ | |||
| 236 | +24x |
- #'+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
||
| 1307 | -+ | |||
| 237 | +24x |
- #' g_el <- h_decompose_gg(gg)+ paste(.spl_context$value, collapse = "_"), |
||
| 1308 | -+ | |||
| 238 | +24x |
- #'+ sep = "_" |
||
| 1309 | +239 |
- #' grid::grid.newpage()+ ) |
||
| 1310 | -+ | |||
| 240 | +24x |
- #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20))+ if (use_cache) {
|
||
| 1311 | -+ | |||
| 241 | +! |
- #' pushViewport(pvp)+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
||
| 1312 | -+ | |||
| 242 | +! |
- #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis))+ x_stats <- cache_env[[var_row_val]] |
||
| 1313 | +243 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA))+ } else {
|
||
| 1314 | -+ | |||
| 244 | +24x |
- #' }+ x_stats <- s_summary(u, ...) |
||
| 1315 | +245 |
- #'+ } |
||
| 1316 | +246 |
- #' @export+ |
||
| 1317 | -+ | |||
| 247 | +24x |
- h_grob_y_annot <- function(ylab, yaxis) {
+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
||
| 1318 | -2x | +248 | +24x |
- grid::gList(+ res <- x_stats[[stat]] |
| 1319 | -2x | +|||
| 249 | +
- grid::gTree(+ } else {
|
|||
| 1320 | -2x | +|||
| 250 | +! |
- vp = grid::viewport(+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
||
| 1321 | -2x | +|||
| 251 | +! |
- width = grid::convertX(yaxis$width + ylab$width, "pt"),+ res_imp <- imputation_rule( |
||
| 1322 | -2x | +|||
| 252 | +! |
- x = grid::unit(1, "npc"),+ .df_row, x_stats, stat, |
||
| 1323 | -2x | +|||
| 253 | +! |
- just = "right"+ imp_rule = imp_rule, |
||
| 1324 | -+ | |||
| 254 | +! |
- ),+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
|
||
| 1325 | -2x | +|||
| 255 | +! |
- children = grid::gList(cbind(ylab, yaxis))+ avalcat_var = avalcat_var |
||
| 1326 | +256 |
- )+ ) |
||
| 1327 | -+ | |||
| 257 | +! |
- )+ res <- res_imp[["val"]]+ |
+ ||
| 258 | +! | +
+ na_str <- res_imp[["na_str"]] |
||
| 1328 | +259 |
- }+ } |
||
| 1329 | +260 | |||
| 1330 | +261 |
- #' Helper Function: Pairwise `CoxPH` table+ # Label check and replacement |
||
| 1331 | -+ | |||
| 262 | +24x |
- #'+ if (length(row_labels) > 1) {
|
||
| 1332 | -+ | |||
| 263 | +12x |
- #' @description `r lifecycle::badge("stable")`
+ if (!(labelstr %in% names(row_labels))) {
|
||
| 1333 | -+ | |||
| 264 | +! |
- #'+ stop( |
||
| 1334 | -+ | |||
| 265 | +! |
- #' Create a `data.frame` of pairwise stratified or unstratified `CoxPH` analysis results.+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
||
| 1335 | -+ | |||
| 266 | +! |
- #'+ "that contains the split values. In the current split variable ", |
||
| 1336 | -+ | |||
| 267 | +! |
- #' @inheritParams g_km+ .spl_context$split[nrow(.spl_context)], |
||
| 1337 | -+ | |||
| 268 | +! |
- #'+ " the labelstr value (split value by default) ", labelstr, " is not in", |
||
| 1338 | -+ | |||
| 269 | +! |
- #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ " row_labels names: ", names(row_labels) |
||
| 1339 | +270 |
- #' and `p-value (log-rank)`.+ ) |
||
| 1340 | +271 |
- #'+ } |
||
| 1341 | -+ | |||
| 272 | +12x |
- #' @examples+ lbl <- unlist(row_labels[labelstr]) |
||
| 1342 | +273 |
- #' \donttest{
+ } else {
|
||
| 1343 | -+ | |||
| 274 | +12x |
- #' library(dplyr)+ lbl <- labelstr |
||
| 1344 | +275 |
- #'+ } |
||
| 1345 | +276 |
- #' adtte <- tern_ex_adtte %>%+ |
||
| 1346 | +277 |
- #' filter(PARAMCD == "OS") %>%+ # Cell creation |
||
| 1347 | -+ | |||
| 278 | +24x |
- #' mutate(is_event = CNSR == 0)+ rcell(res, |
||
| 1348 | -+ | |||
| 279 | +24x |
- #'+ label = lbl, |
||
| 1349 | -+ | |||
| 280 | +24x |
- #' h_tbl_coxph_pairwise(+ format = formats_v[names(formats_v) == stat][[1]], |
||
| 1350 | -+ | |||
| 281 | +24x |
- #' df = adtte,+ format_na_str = na_str, |
||
| 1351 | -+ | |||
| 282 | +24x |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"),+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
||
| 1352 | -+ | |||
| 283 | +24x |
- #' control_coxph_pw = control_coxph(conf_level = 0.9)+ align = .aligns |
||
| 1353 | +284 |
- #' )+ ) |
||
| 1354 | +285 |
- #' }+ } |
||
| 1355 | +286 |
- #'+ }, |
||
| 1356 | -+ | |||
| 287 | +2x |
- #' @export+ stat = .stats, |
||
| 1357 | -+ | |||
| 288 | +2x |
- h_tbl_coxph_pairwise <- function(df,+ use_cache = cache, |
||
| 1358 | -+ | |||
| 289 | +2x |
- variables,+ cache_env = replicate(length(.stats), env) |
||
| 1359 | +290 |
- ref_group_coxph = NULL,+ ) |
||
| 1360 | +291 |
- control_coxph_pw = control_coxph(),+ |
||
| 1361 | +292 |
- annot_coxph_ref_lbls = FALSE) {
+ # Main call to rtables |
||
| 1362 | -3x | +293 | +2x |
- assert_df_with_variables(df, variables)+ summarize_row_groups( |
| 1363 | -3x | +294 | +2x |
- checkmate::assert_choice(ref_group_coxph, levels(df[[variables$arm]]), null.ok = TRUE)+ lyt = lyt, |
| 1364 | -3x | +295 | +2x |
- checkmate::assert_flag(annot_coxph_ref_lbls)+ var = unique(vars), |
| 1365 | -+ | |||
| 296 | +2x |
-
+ cfun = cfun_list, |
||
| 1366 | -3x | +297 | +2x |
- arm <- variables$arm+ na_str = na_str, |
| 1367 | -3x | +298 | +2x |
- df[[arm]] <- factor(df[[arm]])+ extra_args = extra_args |
| 1368 | +299 | - - | -||
| 1369 | -3x | -
- ref_group <- if (!is.null(ref_group_coxph)) ref_group_coxph else levels(df[[variables$arm]])[1]- |
- ||
| 1370 | -3x | -
- comp_group <- setdiff(levels(df[[arm]]), ref_group)+ ) |
||
| 1371 | +300 |
-
+ } else {
|
||
| 1372 | -3x | +|||
| 301 | +
- results <- Map(function(comp) {
+ # Function list for analyze_colvars |
|||
| 1373 | -6x | +302 | +7x |
- res <- s_coxph_pairwise(+ afun_list <- Map( |
| 1374 | -6x | +303 | +7x |
- df = df[df[[arm]] == comp, , drop = FALSE],+ function(stat, use_cache, cache_env) {
|
| 1375 | -6x | +304 | +32x |
- .ref_group = df[df[[arm]] == ref_group, , drop = FALSE],+ function(u, .spl_context, .df_row, ...) {
|
| 1376 | -6x | +|||
| 305 | +
- .in_ref_col = FALSE,+ # Main statistics |
|||
| 1377 | -6x | +306 | +210x |
- .var = variables$tte,+ var_row_val <- paste( |
| 1378 | -6x | +307 | +210x |
- is_event = variables$is_event,+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
| 1379 | -6x | +308 | +210x |
- strat = variables$strat,+ paste(.spl_context$value, collapse = "_"), |
| 1380 | -6x | +309 | +210x |
- control = control_coxph_pw+ sep = "_" |
| 1381 | +310 |
- )+ ) |
||
| 1382 | -6x | +311 | +210x |
- res_df <- data.frame(+ if (use_cache) {
|
| 1383 | -6x | +312 | +16x |
- hr = format(round(res$hr, 2), nsmall = 2),+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
| 1384 | -6x | +313 | +56x |
- hr_ci = paste0(+ x_stats <- cache_env[[var_row_val]] |
| 1385 | -6x | +|||
| 314 | +
- "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
+ } else {
|
|||
| 1386 | -6x | +315 | +154x |
- format(round(res$hr_ci[2], 2), nsmall = 2), ")"+ x_stats <- s_summary(u, ...) |
| 1387 | +316 |
- ),+ }+ |
+ ||
| 317 | ++ | + | ||
| 1388 | -6x | +318 | +210x |
- pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
| 1389 | -6x | +319 | +170x |
- stringsAsFactors = FALSE+ res <- x_stats[[stat]] |
| 1390 | +320 |
- )+ } else {
|
||
| 1391 | -6x | +321 | +40x |
- colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
| 1392 | -6x | +322 | +40x |
- row.names(res_df) <- comp+ res_imp <- imputation_rule( |
| 1393 | -6x | +323 | +40x |
- res_df+ .df_row, x_stats, stat, |
| 1394 | -3x | +324 | +40x |
- }, comp_group)+ imp_rule = imp_rule, |
| 1395 | -! | +|||
| 325 | +40x |
- if (annot_coxph_ref_lbls) names(results) <- paste(comp_group, "vs.", ref_group)+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ |
+ ||
| 326 | +40x | +
+ avalcat_var = avalcat_var |
||
| 1396 | +327 |
-
+ ) |
||
| 1397 | -3x | +328 | +40x |
- do.call(rbind, results)+ res <- res_imp[["val"]]+ |
+
| 329 | +40x | +
+ na_str <- res_imp[["na_str"]] |
||
| 1398 | +330 |
- }+ } |
||
| 1399 | +331 | |||
| 1400 | -+ | |||
| 332 | +210x |
- #' Helper Function: `CoxPH` Grob+ if (is.list(res)) {
|
||
| 1401 | -+ | |||
| 333 | +19x |
- #'+ if (length(res) > 1) {
|
||
| 1402 | -+ | |||
| 334 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ stop("The analyzed column produced more than one category of results.")
|
||
| 1403 | +335 |
- #'+ } else {
|
||
| 1404 | -+ | |||
| 336 | +18x |
- #' Grob of `rtable` output from [h_tbl_coxph_pairwise()]+ res <- unlist(res) |
||
| 1405 | +337 |
- #'+ } |
||
| 1406 | +338 |
- #' @inheritParams h_grob_median_surv+ } |
||
| 1407 | +339 |
- #' @param ... arguments will be passed to [h_tbl_coxph_pairwise()].+ |
||
| 1408 | +340 |
- #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location.+ # Label from context |
||
| 1409 | -+ | |||
| 341 | +209x |
- #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location.+ label_from_context <- .spl_context$value[nrow(.spl_context)] |
||
| 1410 | +342 |
- #' @param width (`unit`)\cr width (as a unit) to use when printing the grob.+ |
||
| 1411 | +343 |
- #'+ # Label switcher |
||
| 1412 | -+ | |||
| 344 | +209x |
- #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ if (is.null(row_labels)) {
|
||
| 1413 | -+ | |||
| 345 | +149x |
- #' and `p-value (log-rank)`.+ lbl <- label_from_context |
||
| 1414 | +346 |
- #'+ } else {
|
||
| 1415 | -+ | |||
| 347 | +60x |
- #' @examples+ if (length(row_labels) > 1) {
|
||
| 1416 | -+ | |||
| 348 | +48x |
- #' \donttest{
+ if (!(label_from_context %in% names(row_labels))) {
|
||
| 1417 | -+ | |||
| 349 | +! |
- #' library(dplyr)+ stop( |
||
| 1418 | -+ | |||
| 350 | +! |
- #' library(survival)+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
||
| 1419 | -+ | |||
| 351 | +! |
- #' library(grid)+ "that contains the split values. In the current split variable ", |
||
| 1420 | -+ | |||
| 352 | +! |
- #'+ .spl_context$split[nrow(.spl_context)], |
||
| 1421 | -+ | |||
| 353 | +! |
- #' grid::grid.newpage()+ " the split value ", label_from_context, " is not in", |
||
| 1422 | -+ | |||
| 354 | +! |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ " row_labels names: ", names(row_labels) |
||
| 1423 | +355 |
- #' data <- tern_ex_adtte %>%+ ) |
||
| 1424 | +356 |
- #' filter(PARAMCD == "OS") %>%+ } |
||
| 1425 | -+ | |||
| 357 | +48x |
- #' mutate(is_event = CNSR == 0)+ lbl <- unlist(row_labels[label_from_context]) |
||
| 1426 | +358 |
- #' tbl_grob <- h_grob_coxph(+ } else {
|
||
| 1427 | -+ | |||
| 359 | +12x |
- #' df = data,+ lbl <- row_labels |
||
| 1428 | +360 |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"),+ } |
||
| 1429 | +361 |
- #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5+ } |
||
| 1430 | +362 |
- #' )+ |
||
| 1431 | +363 |
- #' grid::grid.draw(tbl_grob)+ # Cell creation |
||
| 1432 | -+ | |||
| 364 | +209x |
- #' }+ rcell(res, |
||
| 1433 | -+ | |||
| 365 | +209x |
- #'+ label = lbl, |
||
| 1434 | -+ | |||
| 366 | +209x |
- #' @export+ format = formats_v[names(formats_v) == stat][[1]], |
||
| 1435 | -+ | |||
| 367 | +209x |
- h_grob_coxph <- function(...,+ format_na_str = na_str, |
||
| 1436 | -+ | |||
| 368 | +209x |
- x = 0,+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
||
| 1437 | -+ | |||
| 369 | +209x |
- y = 0,+ align = .aligns |
||
| 1438 | +370 |
- width = grid::unit(0.4, "npc"),+ ) |
||
| 1439 | +371 |
- ttheme = gridExtra::ttheme_default(+ } |
||
| 1440 | +372 |
- padding = grid::unit(c(1, .5), "lines"),+ }, |
||
| 1441 | -+ | |||
| 373 | +7x |
- core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+ stat = .stats, |
||
| 1442 | -+ | |||
| 374 | +7x |
- )) {
+ use_cache = cache, |
||
| 1443 | -2x | +375 | +7x |
- data <- h_tbl_coxph_pairwise(...)+ cache_env = replicate(length(.stats), env) |
| 1444 | +376 | ++ |
+ )+ |
+ |
| 377 | ||||
| 1445 | -2x | +|||
| 378 | +
- width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ # Main call to rtables |
|||
| 1446 | -2x | +379 | +7x |
- height <- width * (nrow(data) + 1) / 12+ analyze_colvars(lyt, |
| 1447 | -+ | |||
| 380 | +7x |
-
+ afun = afun_list, |
||
| 1448 | -2x | +381 | +7x |
- w <- paste(" ", c(
+ na_str = na_str, |
| 1449 | -2x | +382 | +7x |
- rownames(data)[which.max(nchar(rownames(data)))],+ nested = nested, |
| 1450 | -2x | +383 | +7x |
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ extra_args = extra_args |
| 1451 | +384 |
- ))+ ) |
||
| 1452 | -2x | +|||
| 385 | +
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ } |
|||
| 1453 | +386 | ++ |
+ }+ |
+ |
| 387 | ||||
| 1454 | -2x | +|||
| 388 | +
- w_txt <- sapply(1:64, function(x) {
+ # Help function |
|||
| 1455 | -128x | +|||
| 389 | +
- graphics::par(ps = x)+ get_last_col_split <- function(lyt) {
|
|||
| 1456 | -128x | +390 | +1x |
- graphics::strwidth(w[4], units = "in")+ tail(tail(clayout(lyt), 1)[[1]], 1)[[1]] |
| 1457 | +391 |
- })+ } |
||
| 1458 | -2x | +
| 1 | +
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ #' Control function for incidence rate |
|||
| 1459 | +2 |
-
+ #' |
||
| 1460 | -2x | +|||
| 3 | +
- h_txt <- sapply(1:64, function(x) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 1461 | -128x | +|||
| 4 | +
- graphics::par(ps = x)+ #' |
|||
| 1462 | -128x | +|||
| 5 | +
- graphics::strheight(grid::stringHeight("X"), units = "in")
+ #' This is an auxiliary function for controlling arguments for the incidence rate, used |
|||
| 1463 | +6 |
- })+ #' internally to specify details in `s_incidence_rate()`. |
||
| 1464 | -2x | +|||
| 7 | +
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ #' |
|||
| 1465 | +8 |
-
+ #' @inheritParams argument_convention |
||
| 1466 | -2x | +|||
| 9 | +
- if (ttheme$core$fg_params$fontsize == 12) {
+ #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
|||
| 1467 | -2x | +|||
| 10 | +
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' for confidence interval type. |
|||
| 1468 | -2x | +|||
| 11 | +
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default) |
|||
| 1469 | -2x | +|||
| 12 | +
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' indicating time unit for data input. |
|||
| 1470 | +13 |
- }+ #' @param num_pt_year (`numeric`)\cr number of patient-years to use when calculating adverse event rates. |
||
| 1471 | +14 |
-
+ #' @param time_unit_input `r lifecycle::badge("deprecated")` Please use the `input_time_unit` argument instead.
|
||
| 1472 | -2x | +|||
| 15 | +
- tryCatch(+ #' @param time_unit_output `r lifecycle::badge("deprecated")` Please use the `num_pt_year` argument instead.
|
|||
| 1473 | -2x | +|||
| 16 | +
- expr = {
+ #' |
|||
| 1474 | -2x | +|||
| 17 | +
- gt <- gridExtra::tableGrob(+ #' @return A list of components with the same names as the arguments. |
|||
| 1475 | -2x | +|||
| 18 | +
- d = data,+ #' |
|||
| 1476 | -2x | +|||
| 19 | +
- theme = ttheme+ #' @seealso [incidence_rate] |
|||
| 1477 | -2x | +|||
| 20 | +
- ) # ERROR 'data' must be of a vector type, was 'NULL'+ #' |
|||
| 1478 | -2x | +|||
| 21 | +
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ #' @examples |
|||
| 1479 | -2x | +|||
| 22 | +
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ #' control_incidence_rate(0.9, "exact", "month", 100) |
|||
| 1480 | -2x | +|||
| 23 | +
- vp <- grid::viewport(+ #' |
|||
| 1481 | -2x | +|||
| 24 | +
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ #' @export |
|||
| 1482 | -2x | +|||
| 25 | +
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ control_incidence_rate <- function(conf_level = 0.95, |
|||
| 1483 | -2x | +|||
| 26 | +
- height = height,+ conf_type = c("normal", "normal_log", "exact", "byar"),
|
|||
| 1484 | -2x | +|||
| 27 | +
- width = width,+ input_time_unit = c("year", "day", "week", "month"),
|
|||
| 1485 | -2x | +|||
| 28 | +
- just = c("left", "bottom")
+ num_pt_year = 100, |
|||
| 1486 | +29 |
- )+ time_unit_input = lifecycle::deprecated(), |
||
| 1487 | -2x | +|||
| 30 | +
- grid::gList(+ time_unit_output = lifecycle::deprecated()) {
|
|||
| 1488 | -2x | +31 | +8x |
- grid::gTree(+ if (lifecycle::is_present(time_unit_input)) {
|
| 1489 | -2x | +|||
| 32 | +! |
- vp = vp,+ lifecycle::deprecate_warn( |
||
| 1490 | -2x | +|||
| 33 | +! |
- children = grid::gList(gt)+ "0.8.3", "control_incidence_rate(time_unit_input)", "control_incidence_rate(input_time_unit)" |
||
| 1491 | +34 |
- )+ ) |
||
| 1492 | -+ | |||
| 35 | +! |
- )+ input_time_unit <- time_unit_input |
||
| 1493 | +36 |
- },+ } |
||
| 1494 | -2x | +37 | +8x |
- error = function(w) {
+ if (lifecycle::is_present(time_unit_output)) {
|
| 1495 | +38 | ! |
- message(paste(+ lifecycle::deprecate_warn( |
|
| 1496 | +39 | ! |
- "Warning: Cox table will not be displayed as there is",+ "0.8.3", "control_incidence_rate(time_unit_output)", "control_incidence_rate(num_pt_year)"+ |
+ |
| 40 | ++ |
+ ) |
||
| 1497 | +41 | ! |
- "not any level to be compared in the arm variable."+ num_pt_year <- time_unit_output |
|
| 1498 | +42 |
- ))+ } |
||
| 1499 | -! | +|||
| 43 | +
- return(+ |
|||
| 1500 | -! | +|||
| 44 | +8x |
- grid::gList(+ conf_type <- match.arg(conf_type) |
||
| 1501 | -! | +|||
| 45 | +7x |
- grid::gTree(+ input_time_unit <- match.arg(input_time_unit) |
||
| 1502 | -! | +|||
| 46 | +6x |
- vp = NULL,+ checkmate::assert_number(num_pt_year) |
||
| 1503 | -! | +|||
| 47 | +5x |
- children = NULL+ assert_proportion_value(conf_level) |
||
| 1504 | +48 |
- )+ |
||
| 1505 | -+ | |||
| 49 | +4x |
- )+ list( |
||
| 1506 | -+ | |||
| 50 | +4x |
- )+ conf_level = conf_level, |
||
| 1507 | -+ | |||
| 51 | +4x |
- }+ conf_type = conf_type,+ |
+ ||
| 52 | +4x | +
+ input_time_unit = input_time_unit,+ |
+ ||
| 53 | +4x | +
+ num_pt_year = num_pt_year |
||
| 1508 | +54 |
) |
||
| 1509 | +55 |
}@@ -86160,14 +86930,14 @@ tern coverage - 90.46% |
| 1 |
- #' Re-implemented [range()] Default S3 method for numerical objects+ #' Occurrence Table Pruning |
|||
| 3 |
- #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data+ #' @description `r lifecycle::badge("stable")`
|
|||
| 4 |
- #' without any warnings.+ #' |
|||
| 5 |
- #'+ #' Family of constructor and condition functions to flexibly prune occurrence tables. |
|||
| 6 |
- #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed.+ #' The condition functions always return whether the row result is higher than the threshold. |
|||
| 7 |
- #' @param na.rm (`logical`)\cr indicating if `NA` should be omitted.+ #' Since they are of class [CombinationFunction()] they can be logically combined with other condition |
|||
| 8 |
- #' @param finite (`logical`)\cr indicating if non-finite elements should be removed.+ #' functions. |
|||
| 10 |
- #' @return A 2-element vector of class `numeric`.+ #' @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 |
- #' @keywords internal+ #' should be pruned, to conform with the [rtables::prune_table()] interface. |
|||
| 13 |
- range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
+ #' |
|||
| 14 |
-
+ #' @examples |
|||
| 15 | -953x | +
- checkmate::assert_numeric(x)+ #' \donttest{
|
||
| 16 |
-
+ #' tab <- basic_table() %>% |
|||
| 17 | -953x | +
- if (finite) {
+ #' split_cols_by("ARM") %>%
|
||
| 18 | -24x | +
- x <- x[is.finite(x)] # removes NAs too+ #' split_rows_by("RACE") %>%
|
||
| 19 | -929x | +
- } else if (na.rm) {
+ #' split_rows_by("STRATA1") %>%
|
||
| 20 | -558x | +
- x <- x[!is.na(x)]+ #' summarize_row_groups() %>% |
||
| 21 |
- }+ #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
|
|||
| 22 |
-
+ #' build_table(DM) |
|||
| 23 | -953x | +
- if (length(x) == 0) {
+ #' } |
||
| 24 | -52x | +
- rval <- c(NA, NA)+ #' |
||
| 25 | -52x | +
- mode(rval) <- typeof(x)+ #' @name prune_occurrences |
||
| 26 |
- } else {
+ NULL |
|||
| 27 | -901x | +
- rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))+ |
||
| 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 | -953x | +
- return(rval)+ #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no |
||
| 31 |
- }+ #' children left. |
|||
| 32 |
-
+ #' |
|||
| 33 |
- #' Utility function to create label for confidence interval+ #' @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 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
|||
| 36 |
- #'+ #' @return |
|||
| 37 |
- #' @inheritParams argument_convention+ #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()] |
|||
| 38 |
- #'+ #' to prune an `rtables` table. |
|||
| 39 |
- #' @return A `string`.+ #' |
|||
| 40 |
- #'+ #' @examples |
|||
| 41 |
- #' @export+ #' \donttest{
|
|||
| 42 |
- f_conf_level <- function(conf_level) {
+ #' # `keep_rows` |
|||
| 43 | -1521x | +
- assert_proportion_value(conf_level)+ #' is_non_empty <- !CombinationFunction(all_zero_or_na) |
||
| 44 | -1519x | +
- paste0(conf_level * 100, "% CI")+ #' prune_table(tab, keep_rows(is_non_empty)) |
||
| 45 |
- }+ #' } |
|||
| 46 |
-
+ #' |
|||
| 47 |
- #' Utility function to create label for p-value+ #' @export |
|||
| 48 |
- #'+ keep_rows <- function(row_condition) {
|
|||
| 49 | -+ | 6x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_function(row_condition) |
|
| 50 | -+ | 6x |
- #'+ function(table_tree) {
|
|
| 51 | -+ | 2256x |
- #' @param test_mean (`number`)\cr mean value to test under the null hypothesis.+ if (inherits(table_tree, "TableRow")) {
|
|
| 52 | -+ | 1872x |
- #'+ return(!row_condition(table_tree)) |
|
| 53 |
- #' @return A `string`.+ } |
|||
| 54 | -+ | 384x |
- #'+ children <- tree_children(table_tree) |
|
| 55 | -+ | 384x |
- #' @export+ identical(length(children), 0L) |
|
| 56 |
- f_pval <- function(test_mean) {
+ } |
|||
| 57 | -363x | +
- checkmate::assert_numeric(test_mean, len = 1)+ } |
||
| 58 | -361x | +
- paste0("p-value (H0: mean = ", test_mean, ")")
+
|
||
| 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 |
- #' Utility function to return a named list of covariate names.+ #' 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 |
- #' @param covariates (`character`)\cr a vector that can contain single variable names (such as+ #' |
|||
| 64 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' @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 |
- #' @return A named `list` of `character` vector.+ #' |
|||
| 67 |
- #'+ #' @return |
|||
| 68 |
- #' @keywords internal+ #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content |
|||
| 69 |
- get_covariates <- function(covariates) {
+ #' row of leaf tables in the table. |
|||
| 70 | -14x | +
- checkmate::assert_character(covariates)+ #' |
||
| 71 | -12x | +
- cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*"))))+ #' @examples |
||
| 72 | -12x | +
- stats::setNames(as.list(cov_vars), cov_vars)+ #' # `keep_content_rows` |
||
| 73 |
- }+ #' \donttest{
|
|||
| 74 |
-
+ #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab)) |
|||
| 75 |
- #' Replicate Entries of a Vector if Required+ #' prune_table(tab, keep_content_rows(more_than_twenty)) |
|||
| 76 |
- #'+ #' } |
|||
| 77 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
|||
| 78 |
- #'+ #' @export |
|||
| 79 |
- #' Replicate entries of a vector if required.+ keep_content_rows <- function(content_row_condition) {
|
|||
| 80 | -+ | 1x |
- #'+ checkmate::assert_function(content_row_condition) |
|
| 81 | -+ | 1x |
- #' @inheritParams argument_convention+ function(table_tree) {
|
|
| 82 | -+ | 166x |
- #' @param n (`count`)\cr how many entries we need.+ if (is_leaf_table(table_tree)) {
|
|
| 83 | -+ | 24x |
- #'+ content_row <- h_content_first_row(table_tree) |
|
| 84 | -+ | 24x |
- #' @return `x` if it has the required length already or is `NULL`,+ return(!content_row_condition(content_row)) |
|
| 85 |
- #' otherwise if it is scalar the replicated version of it with `n` entries.+ } |
|||
| 86 | -+ | 142x |
- #'+ if (inherits(table_tree, "DataRow")) {
|
|
| 87 | -+ | 120x |
- #' @note This function will fail if `x` is not of length `n` and/or is not a scalar.+ return(FALSE) |
|
| 88 |
- #'+ } |
|||
| 89 | -+ | 22x |
- #' @export+ children <- tree_children(table_tree) |
|
| 90 | -+ | 22x |
- to_n <- function(x, n) {
+ identical(length(children), 0L) |
|
| 91 | -1x | +
- if (is.null(x)) {
+ } |
||
| 92 | -! | +
- NULL+ } |
||
| 93 | -1x | +
- } else if (length(x) == 1) {
+
|
||
| 94 | -! | +
- rep(x, n)+ #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns. |
||
| 95 | -1x | +
- } else if (length(x) == n) {
+ #' |
||
| 96 | -1x | +
- x+ #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row. |
||
| 97 |
- } else {
+ #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including |
|||
| 98 | -! | +
- stop("dimension mismatch")
+ #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices |
||
| 99 |
- }+ #' directly instead. |
|||
| 100 |
- }+ #' |
|||
| 101 |
-
+ #' @return |
|||
| 102 |
- #' Check Element Dimension+ #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column. |
|||
| 104 |
- #' Checks if the elements in `...` have the same dimension.+ #' @examples |
|||
| 105 |
- #'+ #' \donttest{
|
|||
| 106 |
- #' @param ... (`data.frame`s or `vector`s)\cr any data frames/vectors.+ #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab)) |
|||
| 107 |
- #' @param omit_null (`logical`)\cr whether `NULL` elements in `...` should be omitted from the check.+ #' prune_table(tab, keep_rows(more_than_one)) |
|||
| 108 |
- #'+ #' } |
|||
| 109 |
- #' @return A `logical` value.+ #' |
|||
| 110 |
- #'+ #' @export |
|||
| 111 |
- #' @keywords internal+ has_count_in_cols <- function(atleast, ...) {
|
|||
| 112 | -+ | 3x |
- check_same_n <- function(..., omit_null = TRUE) {
+ checkmate::assert_count(atleast) |
|
| 113 | -2x | +3x |
- dots <- list(...)+ CombinationFunction(function(table_row) {
|
|
| 114 | -+ | 334x |
-
+ row_counts <- h_row_counts(table_row, ...) |
|
| 115 | -2x | +334x |
- n_list <- Map(+ total_count <- sum(row_counts) |
|
| 116 | -2x | +334x |
- function(x, name) {
+ total_count >= atleast |
|
| 117 | -5x | +
- if (is.null(x)) {
+ }) |
||
| 118 | -! | +
- if (omit_null) {
+ } |
||
| 119 | -2x | +
- NA_integer_+ |
||
| 120 |
- } else {
+ #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in |
|||
| 121 | -! | +
- stop("arg", name, "is not supposed to be NULL")
+ #' the specified columns satisfying a threshold. |
||
| 122 |
- }+ #' |
|||
| 123 | -5x | +
- } else if (is.data.frame(x)) {
+ #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row. |
||
| 124 | -! | +
- nrow(x)+ #' |
||
| 125 | -5x | +
- } else if (is.atomic(x)) {
+ #' @return |
||
| 126 | -5x | +
- length(x)+ #' * `has_count_in_any_col()` returns a condition function that compares the counts in the |
||
| 127 |
- } else {
+ #' specified columns with the threshold. |
|||
| 128 | -! | +
- stop("data structure for ", name, "is currently not supported")
+ #' |
||
| 129 |
- }+ #' @examples |
|||
| 130 |
- },+ #' \donttest{
|
|||
| 131 | -2x | +
- dots, names(dots)+ #' # `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 | -2x | +
- n <- stats::na.omit(unlist(n_list))+ #' } |
||
| 135 | + |
+ #'+ |
+ ||
| 136 | ++ |
+ #' @export+ |
+ ||
| 137 | ++ |
+ has_count_in_any_col <- function(atleast, ...) {
+ |
+ ||
| 138 | +! | +
+ checkmate::assert_count(atleast)+ |
+ ||
| 139 | +! | +
+ CombinationFunction(function(table_row) {
+ |
+ ||
| 140 | +! | +
+ row_counts <- h_row_counts(table_row, ...)+ |
+ ||
| 141 | +! | +
+ 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, ...) {
+ |
+ ||
| 136 | -2x | +161 | +1x |
- if (length(unique(n)) > 1) {
+ assert_proportion_value(atleast, include_boundaries = TRUE)+ |
+
| 162 | +1x | +
+ CombinationFunction(function(table_row) {
+ |
+ ||
| 163 | +303x | +
+ row_counts <- h_row_counts(table_row, ...)+ |
+ ||
| 164 | +303x | +
+ total_count <- sum(row_counts)+ |
+ ||
| 165 | +303x | +
+ col_counts <- h_col_counts(table_row, ...)+ |
+ ||
| 166 | +303x | +
+ total_n <- sum(col_counts)+ |
+ ||
| 167 | +303x | +
+ total_percent <- total_count / total_n+ |
+ ||
| 168 | +303x | +
+ 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(more_than_five_percent))+ |
+ ||
| 184 | ++ |
+ #' }+ |
+ ||
| 185 | ++ |
+ #'+ |
+ ||
| 186 | ++ |
+ #' @export+ |
+ ||
| 187 | ++ |
+ has_fraction_in_any_col <- function(atleast, ...) {
|
||
| 137 | +188 | ! |
- sel <- which(n != n[1])+ assert_proportion_value(atleast, include_boundaries = TRUE) |
|
| 138 | +189 | ! |
- stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
+ CombinationFunction(function(table_row) {
+ |
+ |
| 190 | +! | +
+ row_fractions <- h_row_fractions(table_row, ...)+ |
+ ||
| 191 | +! | +
+ 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 | ++ |
+ #' |
||
| 139 | +198 |
- }+ #' @return |
||
| 140 | +199 |
-
+ #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each |
||
| 141 | -2x | +|||
| 200 | +
- TRUE+ #' specified column, and computes the difference of the minimum and maximum. |
|||
| 142 | +201 |
- }+ #' |
||
| 143 | +202 |
-
+ #' @examples |
||
| 144 | +203 |
- #' Make Names Without Dots+ #' \donttest{
|
||
| 145 | +204 |
- #'+ #' # `has_fractions_difference` |
||
| 146 | +205 |
- #' @param nams (`character`)\cr vector of original names.+ #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab)) |
||
| 147 | +206 |
- #'+ #' prune_table(tab, keep_rows(more_than_five_percent_diff)) |
||
| 148 | +207 |
- #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()].+ #' } |
||
| 149 | +208 |
#' |
||
| 150 | +209 |
- #' @keywords internal+ #' @export |
||
| 151 | +210 |
- make_names <- function(nams) {
+ has_fractions_difference <- function(atleast, ...) {
|
||
| 152 | -6x | +211 | +1x |
- orig <- make.names(nams)+ assert_proportion_value(atleast, include_boundaries = TRUE) |
| 153 | -6x | +212 | +1x |
- gsub(".", "", x = orig, fixed = TRUE)
+ CombinationFunction(function(table_row) {
|
| 154 | -+ | |||
| 213 | +243x |
- }+ fractions <- h_row_fractions(table_row, ...)+ |
+ ||
| 214 | +243x | +
+ difference <- diff(range(fractions))+ |
+ ||
| 215 | +243x | +
+ difference >= atleast |
||
| 155 | +216 |
-
+ }) |
||
| 156 | +217 |
- #' Conversion of Months to Days+ } |
||
| 157 | +218 |
- #'+ |
||
| 158 | +219 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
||
| 159 | +220 |
- #'+ #' between the counts reported in each specified column. |
||
| 160 | +221 |
- #' Conversion of Months to Days. This is an approximative calculation because it+ #' |
||
| 161 | +222 |
- #' considers each month as having an average of 30.4375 days.+ #' @return |
||
| 162 | +223 |
- #'+ #' * `has_counts_difference()` returns a condition function that extracts the counts of each |
||
| 163 | +224 |
- #' @param x (`numeric`)\cr time in months.+ #' specified column, and computes the difference of the minimum and maximum. |
||
| 164 | +225 |
#' |
||
| 165 | +226 |
- #' @return A `numeric` vector with the time in days.+ #' @examples |
||
| 166 | +227 |
- #'+ #' \donttest{
|
||
| 167 | +228 |
- #' @examples+ #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab)) |
||
| 168 | +229 |
- #' x <- c(13.25, 8.15, 1, 2.834)+ #' prune_table(tab, keep_rows(more_than_one_diff)) |
||
| 169 | +230 |
- #' month2day(x)+ #' } |
||
| 170 | +231 |
#' |
||
| 171 | +232 |
#' @export |
||
| 172 | +233 |
- month2day <- function(x) {
+ has_counts_difference <- function(atleast, ...) {
|
||
| 173 | +234 | 1x |
- checkmate::assert_numeric(x)+ checkmate::assert_count(atleast) |
|
| 174 | +235 | 1x |
- x * 30.4375+ CombinationFunction(function(table_row) {
+ |
+ |
| 236 | +27x | +
+ counts <- h_row_counts(table_row, ...)+ |
+ ||
| 237 | +27x | +
+ difference <- diff(range(counts))+ |
+ ||
| 238 | +27x | +
+ difference >= atleast |
||
| 175 | +239 |
- }+ }) |
||
| 176 | +240 |
-
+ } |
| 177 | +1 |
- #' Conversion of Days to Months+ #' Survival Time Point Analysis |
||
| 178 | +2 |
#' |
||
| 179 | +3 |
- #' @param x (`numeric`)\cr time in days.+ #' @description `r lifecycle::badge("stable")`
|
||
| 180 | +4 |
#' |
||
| 181 | +5 |
- #' @return A `numeric` vector with the time in months.+ #' Summarize patients' survival rate and difference of survival rates between groups at a time point. |
||
| 182 | +6 |
#' |
||
| 183 | +7 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 184 | +8 |
- #' x <- c(403, 248, 30, 86)+ #' @inheritParams s_surv_time |
||
| 185 | +9 |
- #' day2month(x)+ #' @param time_point (`number`)\cr survival time point of interest. |
||
| 186 | +10 |
- #'+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 187 | +11 |
- #' @export+ #' [control_surv_timepoint()]. Some possible parameter options are: |
||
| 188 | +12 |
- day2month <- function(x) {
- |
- ||
| 189 | -19x | -
- checkmate::assert_numeric(x)+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
||
| 190 | -19x | +|||
| 13 | +
- x / 30.4375+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
|||
| 191 | +14 |
- }+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
||
| 192 | +15 |
-
+ #' * `time_point` (`number`)\cr survival time point of interest. |
||
| 193 | +16 |
- #' Return an empty numeric if all elements are `NA`.+ #' @param method (`string`)\cr either `surv` (survival estimations), |
||
| 194 | +17 |
- #'+ #' `surv_diff` (difference in survival with the control) or `both`. |
||
| 195 | +18 |
- #' @param x (`numeric`)\cr vector.+ #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to |
||
| 196 | +19 |
- #'+ #' avoid warnings from duplicate table names. |
||
| 197 | +20 |
- #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_timepoint")`
|
||
| 198 | +21 |
- #'+ #' to see available statistics for this function. |
||
| 199 | +22 |
- #' @examples+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 200 | +23 |
- #' x <- c(NA, NA, NA)+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 201 | +24 |
- #' # Internal function - empty_vector_if_na+ #' for that statistic's row label. |
||
| 202 | +25 |
- #' @keywords internal+ #' |
||
| 203 | +26 |
- empty_vector_if_na <- function(x) {
+ #' @name survival_timepoint |
||
| 204 | -683x | +|||
| 27 | +
- if (all(is.na(x))) {
+ #' @order 1 |
|||
| 205 | -220x | +|||
| 28 | +
- numeric()+ NULL |
|||
| 206 | +29 |
- } else {
+
|
||
| 207 | -463x | +|||
| 30 | +
- x+ #' @describeIn survival_timepoint Statistics function which analyzes survival rate. |
|||
| 208 | +31 |
- }+ #' |
||
| 209 | +32 |
- }+ #' @return |
||
| 210 | +33 |
-
+ #' * `s_surv_timepoint()` returns the statistics: |
||
| 211 | +34 |
- #' Combine Two Vectors Element Wise+ #' * `pt_at_risk`: Patients remaining at risk. |
||
| 212 | +35 |
- #'+ #' * `event_free_rate`: Event-free rate (%). |
||
| 213 | +36 |
- #' @param x (`vector`)\cr first vector to combine.+ #' * `rate_se`: Standard error of event free rate. |
||
| 214 | +37 |
- #' @param y (`vector`)\cr second vector to combine.+ #' * `rate_ci`: Confidence interval for event free rate. |
||
| 215 | +38 |
#' |
||
| 216 | +39 |
- #' @return A `list` where each element combines corresponding elements of `x` and `y`.+ #' @keywords internal |
||
| 217 | +40 |
- #'+ s_surv_timepoint <- function(df, |
||
| 218 | +41 |
- #' @examples+ .var, |
||
| 219 | +42 |
- #' combine_vectors(1:3, 4:6)+ time_point, |
||
| 220 | +43 |
- #'+ is_event, |
||
| 221 | +44 |
- #' @export+ control = control_surv_timepoint()) {
+ |
+ ||
| 45 | +23x | +
+ checkmate::assert_string(.var)+ |
+ ||
| 46 | +23x | +
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ |
+ ||
| 47 | +23x | +
+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ |
+ ||
| 48 | +23x | +
+ checkmate::assert_number(time_point)+ |
+ ||
| 49 | +23x | +
+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
||
| 222 | +50 |
- combine_vectors <- function(x, y) {
+
|
||
| 223 | -70x | +51 | +23x |
- checkmate::assert_vector(x)+ conf_type <- control$conf_type |
| 224 | -70x | +52 | +23x |
- checkmate::assert_vector(y, len = length(x))+ conf_level <- control$conf_level |
| 225 | +53 | |||
| 226 | -70x | +54 | +23x |
- result <- lapply(as.data.frame(rbind(x, y)), `c`)+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
| 227 | -70x | +55 | +23x |
- names(result) <- NULL+ srv_fit <- survival::survfit( |
| 228 | -70x | +56 | +23x |
- result+ formula = formula, |
| 229 | -+ | |||
| 57 | +23x |
- }+ data = df, |
||
| 230 | -+ | |||
| 58 | +23x |
-
+ conf.int = conf_level, |
||
| 231 | -+ | |||
| 59 | +23x |
- #' Extract Elements by Name+ conf.type = conf_type |
||
| 232 | +60 |
- #'+ ) |
||
| 233 | -+ | |||
| 61 | +23x |
- #' This utility function extracts elements from a vector `x` by `names`.+ s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE) |
||
| 234 | -+ | |||
| 62 | +23x |
- #' Differences to the standard `[` function are:+ df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
|
||
| 235 | -+ | |||
| 63 | +23x |
- #'+ if (df_srv_fit[["n.risk"]] == 0) {
|
||
| 236 | -+ | |||
| 64 | +1x |
- #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).+ pt_at_risk <- event_free_rate <- rate_se <- NA_real_+ |
+ ||
| 65 | +1x | +
+ rate_ci <- c(NA_real_, NA_real_) |
||
| 237 | +66 |
- #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those+ } else {
+ |
+ ||
| 67 | +22x | +
+ pt_at_risk <- df_srv_fit$n.risk+ |
+ ||
| 68 | +22x | +
+ event_free_rate <- df_srv_fit$surv+ |
+ ||
| 69 | +22x | +
+ rate_se <- df_srv_fit$std.err+ |
+ ||
| 70 | +22x | +
+ rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper) |
||
| 238 | +71 |
- #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.+ }+ |
+ ||
| 72 | +23x | +
+ list(+ |
+ ||
| 73 | +23x | +
+ pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),+ |
+ ||
| 74 | +23x | +
+ event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),+ |
+ ||
| 75 | +23x | +
+ rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),+ |
+ ||
| 76 | +23x | +
+ rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level)) |
||
| 239 | +77 |
- #'+ ) |
||
| 240 | +78 |
- #' @param x (named `vector`)\cr where to extract named elements from.+ } |
||
| 241 | +79 |
- #' @param names (`character`)\cr vector of names to extract.+ |
||
| 242 | +80 |
- #'+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
||
| 243 | +81 |
- #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`.+ #' when `method = "surv"`. |
||
| 244 | +82 |
#' |
||
| 245 | +83 |
- #' @keywords internal+ #' @return |
||
| 246 | +84 |
- extract_by_name <- function(x, names) {
+ #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 247 | -3x | +|||
| 85 | +
- if (is.null(x)) {
+ #' |
|||
| 248 | -1x | +|||
| 86 | +
- return(NULL)+ #' @keywords internal |
|||
| 249 | +87 |
- }+ a_surv_timepoint <- make_afun( |
||
| 250 | -2x | +|||
| 88 | +
- checkmate::assert_named(x)+ s_surv_timepoint, |
|||
| 251 | -2x | +|||
| 89 | +
- checkmate::assert_character(names)+ .indent_mods = c( |
|||
| 252 | -2x | +|||
| 90 | +
- which_extract <- intersect(names(x), names)+ pt_at_risk = 0L, |
|||
| 253 | -2x | +|||
| 91 | +
- if (length(which_extract) > 0) {
+ event_free_rate = 0L, |
|||
| 254 | -1x | +|||
| 92 | +
- x[which_extract]+ rate_se = 1L, |
|||
| 255 | +93 |
- } else {
+ rate_ci = 1L |
||
| 256 | -1x | +|||
| 94 | +
- NULL+ ), |
|||
| 257 | +95 |
- }+ .formats = c( |
||
| 258 | +96 |
- }+ pt_at_risk = "xx", |
||
| 259 | +97 |
-
+ event_free_rate = "xx.xx", |
||
| 260 | +98 |
- #' Labels for Adverse Event Baskets+ rate_se = "xx.xx", |
||
| 261 | +99 |
- #'+ rate_ci = "(xx.xx, xx.xx)" |
||
| 262 | +100 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 263 | +101 |
- #'+ ) |
||
| 264 | +102 |
- #' @param aesi (`character`)\cr with standardized `MedDRA` query name (e.g. `SMQzzNAM`) or customized query+ |
||
| 265 | +103 |
- #' name (e.g. `CQzzNAM`).+ #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates. |
||
| 266 | +104 |
- #' @param scope (`character`)\cr with scope of query (e.g. `SMQzzSC`).+ #' |
||
| 267 | +105 |
- #'+ #' @return |
||
| 268 | +106 |
- #' @return A `string` with the standard label for the `AE` basket.+ #' * `s_surv_timepoint_diff()` returns the statistics: |
||
| 269 | +107 |
- #'+ #' * `rate_diff`: Event-free rate difference between two groups. |
||
| 270 | +108 |
- #' @examples+ #' * `rate_diff_ci`: Confidence interval for the difference. |
||
| 271 | +109 |
- #' adae <- tern_ex_adae+ #' * `ztest_pval`: p-value to test the difference is 0. |
||
| 272 | +110 |
#' |
||
| 273 | +111 |
- #' # Standardized query label includes scope.+ #' @keywords internal |
||
| 274 | +112 |
- #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)+ s_surv_timepoint_diff <- function(df, |
||
| 275 | +113 |
- #'+ .var, |
||
| 276 | +114 |
- #' # Customized query label.+ .ref_group, |
||
| 277 | +115 |
- #' aesi_label(adae$CQ01NAM)+ .in_ref_col, |
||
| 278 | +116 |
- #'+ time_point, |
||
| 279 | +117 |
- #' @export+ control = control_surv_timepoint(), |
||
| 280 | +118 |
- aesi_label <- function(aesi, scope = NULL) {
+ ...) {
|
||
| 281 | -3x | +119 | +2x |
- checkmate::assert_character(aesi)+ if (.in_ref_col) {
|
| 282 | -3x | +|||
| 120 | +! |
- checkmate::assert_character(scope, null.ok = TRUE)+ return( |
||
| 283 | -3x | +|||
| 121 | +! |
- aesi_label <- obj_label(aesi)+ list( |
||
| 284 | -3x | +|||
| 122 | +! |
- aesi <- sas_na(aesi)+ rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
|
||
| 285 | -3x | +|||
| 123 | +! |
- aesi <- unique(aesi)[!is.na(unique(aesi))]+ rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ |
+ ||
| 124 | +! | +
+ ztest_pval = formatters::with_label("", "p-value (Z-test)")
|
||
| 286 | +125 |
-
+ ) |
||
| 287 | -3x | +|||
| 126 | +
- lbl <- if (length(aesi) == 1 && !is.null(scope)) {
+ ) |
|||
| 288 | -1x | +|||
| 127 | +
- scope <- sas_na(scope)+ } |
|||
| 289 | -1x | +128 | +2x |
- scope <- unique(scope)[!is.na(unique(scope))]+ data <- rbind(.ref_group, df) |
| 290 | -1x | +129 | +2x |
- checkmate::assert_string(scope)+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
| 291 | -1x | +130 | +2x |
- paste0(aesi, " (", scope, ")")
+ res_per_group <- lapply(split(data, group), function(x) {
|
| 292 | -3x | +131 | +4x |
- } else if (length(aesi) == 1 && is.null(scope)) {
+ s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...) |
| 293 | -1x | +|||
| 132 | +
- aesi+ }) |
|||
| 294 | +133 |
- } else {
+
|
||
| 295 | -1x | +134 | +2x |
- aesi_label+ res_x <- res_per_group[[2]] |
| 296 | -+ | |||
| 135 | +2x |
- }+ res_ref <- res_per_group[[1]] |
||
| 297 | -+ | |||
| 136 | +2x |
-
+ rate_diff <- res_x$event_free_rate - res_ref$event_free_rate |
||
| 298 | -3x | +137 | +2x |
- lbl+ se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2) |
| 299 | +138 |
- }+ |
||
| 300 | -+ | |||
| 139 | +2x |
-
+ qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2) |
||
| 301 | -+ | |||
| 140 | +2x |
- #' Indicate Study Arm Variable in Formula+ rate_diff_ci <- rate_diff + qs * se_diff |
||
| 302 | -+ | |||
| 141 | +2x |
- #'+ ztest_pval <- if (is.na(rate_diff)) {
|
||
| 303 | -+ | |||
| 142 | +2x |
- #' We use `study_arm` to indicate the study arm variable in `tern` formulas.+ NA |
||
| 304 | +143 |
- #'+ } else {
|
||
| 305 | -+ | |||
| 144 | +2x |
- #' @param x arm information+ 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff)) |
||
| 306 | +145 |
- #'+ } |
||
| 307 | -+ | |||
| 146 | +2x |
- #' @return `x`+ list( |
||
| 308 | -+ | |||
| 147 | +2x |
- #'+ rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"), |
||
| 309 | -+ | |||
| 148 | +2x |
- #' @keywords internal+ rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)), |
||
| 310 | -+ | |||
| 149 | +2x |
- study_arm <- function(x) {
+ ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)") |
||
| 311 | -! | +|||
| 150 | +
- structure(x, varname = deparse(substitute(x)))+ ) |
|||
| 312 | +151 |
} |
||
| 313 | +152 | |||
| 314 | +153 |
- #' Smooth Function with Optional Grouping+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
||
| 315 | +154 |
- #'+ #' when `method = "surv_diff"`. |
||
| 316 | +155 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 317 | +156 |
- #'+ #' @return |
||
| 318 | +157 |
- #' This produces `loess` smoothed estimates of `y` with Student confidence intervals.+ #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 319 | +158 |
#' |
||
| 320 | +159 |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ #' @keywords internal |
||
| 321 | +160 |
- #' @param x (`character`)\cr value with x column name.+ a_surv_timepoint_diff <- make_afun( |
||
| 322 | +161 |
- #' @param y (`character`)\cr value with y column name.+ s_surv_timepoint_diff, |
||
| 323 | +162 |
- #' @param groups (`character`)\cr vector with optional grouping variables names.+ .formats = c( |
||
| 324 | +163 |
- #' @param level (`numeric`)\cr level of confidence interval to use (0.95 by default).+ rate_diff = "xx.xx", |
||
| 325 | +164 |
- #'+ rate_diff_ci = "(xx.xx, xx.xx)", |
||
| 326 | +165 |
- #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and+ ztest_pval = "x.xxxx | (<0.0001)" |
||
| 327 | +166 |
- #' optional `groups` variables formatted as `factor` type.+ ) |
||
| 328 | +167 |
- #'+ ) |
||
| 329 | +168 |
- #' @export+ |
||
| 330 | +169 |
- get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
+ #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments |
||
| 331 | -5x | +|||
| 170 | +
- checkmate::assert_data_frame(df)+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 332 | -5x | +|||
| 171 | +
- df_cols <- colnames(df)+ #' |
|||
| 333 | -5x | +|||
| 172 | +
- checkmate::assert_string(x)+ #' @return |
|||
| 334 | -5x | +|||
| 173 | +
- checkmate::assert_subset(x, df_cols)+ #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions, |
|||
| 335 | -5x | +|||
| 174 | +
- checkmate::assert_numeric(df[[x]])+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 336 | -5x | +|||
| 175 | +
- checkmate::assert_string(y)+ #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on |
|||
| 337 | -5x | +|||
| 176 | +
- checkmate::assert_subset(y, df_cols)+ #' the value of `method`. |
|||
| 338 | -5x | +|||
| 177 | +
- checkmate::assert_numeric(df[[y]])+ #' |
|||
| 339 | +178 |
-
+ #' @examples |
||
| 340 | -5x | +|||
| 179 | +
- if (!is.null(groups)) {
+ #' library(dplyr) |
|||
| 341 | -4x | +|||
| 180 | +
- checkmate::assert_character(groups)+ #' |
|||
| 342 | -4x | +|||
| 181 | +
- checkmate::assert_subset(groups, df_cols)+ #' adtte_f <- tern_ex_adtte %>% |
|||
| 343 | +182 |
- }+ #' filter(PARAMCD == "OS") %>% |
||
| 344 | +183 |
-
+ #' mutate( |
||
| 345 | -5x | +|||
| 184 | +
- smooths <- function(x, y) {
+ #' AVAL = day2month(AVAL), |
|||
| 346 | -18x | +|||
| 185 | +
- stats::predict(stats::loess(y ~ x), se = TRUE)+ #' is_event = CNSR == 0 |
|||
| 347 | +186 |
- }+ #' ) |
||
| 348 | +187 |
-
+ #' |
||
| 349 | -5x | +|||
| 188 | +
- if (!is.null(groups)) {
+ #' # Survival at given time points. |
|||
| 350 | -4x | +|||
| 189 | +
- cc <- stats::complete.cases(df[c(x, y, groups)])+ #' basic_table() %>% |
|||
| 351 | -4x | +|||
| 190 | +
- df_c <- df[cc, c(x, y, groups)]+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|||
| 352 | -4x | +|||
| 191 | +
- df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
+ #' add_colcounts() %>% |
|||
| 353 | -4x | +|||
| 192 | +
- df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))+ #' surv_timepoint( |
|||
| 354 | +193 |
-
+ #' vars = "AVAL", |
||
| 355 | -4x | +|||
| 194 | +
- df_smooth_raw <-+ #' var_labels = "Months", |
|||
| 356 | -4x | +|||
| 195 | +
- by(df_c_ordered, df_c_g, function(d) {
+ #' is_event = "is_event", |
|||
| 357 | -17x | +|||
| 196 | +
- plx <- smooths(d[[x]], d[[y]])+ #' time_point = 7 |
|||
| 358 | -17x | +|||
| 197 | +
- data.frame(+ #' ) %>% |
|||
| 359 | -17x | +|||
| 198 | +
- x = d[[x]],+ #' build_table(df = adtte_f) |
|||
| 360 | -17x | +|||
| 199 | +
- y = plx$fit,+ #' |
|||
| 361 | -17x | +|||
| 200 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se,+ #' # Difference in survival at given time points. |
|||
| 362 | -17x | +|||
| 201 | +
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se+ #' basic_table() %>% |
|||
| 363 | +202 |
- )+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 364 | +203 |
- })+ #' add_colcounts() %>% |
||
| 365 | +204 |
-
+ #' surv_timepoint( |
||
| 366 | -4x | +|||
| 205 | +
- df_smooth <- do.call(rbind, df_smooth_raw)+ #' vars = "AVAL", |
|||
| 367 | -4x | +|||
| 206 | +
- df_smooth[groups] <- df_c_g+ #' var_labels = "Months", |
|||
| 368 | +207 |
-
+ #' is_event = "is_event", |
||
| 369 | -4x | +|||
| 208 | +
- df_smooth+ #' time_point = 9, |
|||
| 370 | +209 |
- } else {
+ #' method = "surv_diff", |
||
| 371 | -1x | +|||
| 210 | +
- cc <- stats::complete.cases(df[c(x, y)])+ #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
|
|||
| 372 | -1x | +|||
| 211 | +
- df_c <- df[cc, ]+ #' ) %>% |
|||
| 373 | -1x | +|||
| 212 | +
- plx <- smooths(df_c[[x]], df_c[[y]])+ #' build_table(df = adtte_f) |
|||
| 374 | +213 |
-
+ #' |
||
| 375 | -1x | +|||
| 214 | +
- df_smooth <- data.frame(+ #' # Survival and difference in survival at given time points. |
|||
| 376 | -1x | +|||
| 215 | +
- x = df_c[[x]],+ #' basic_table() %>% |
|||
| 377 | -1x | +|||
| 216 | +
- y = plx$fit,+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|||
| 378 | -1x | +|||
| 217 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se,+ #' add_colcounts() %>% |
|||
| 379 | -1x | +|||
| 218 | +
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se+ #' surv_timepoint( |
|||
| 380 | +219 |
- )+ #' vars = "AVAL", |
||
| 381 | +220 |
-
+ #' var_labels = "Months", |
||
| 382 | -1x | +|||
| 221 | +
- df_smooth+ #' is_event = "is_event", |
|||
| 383 | +222 |
- }+ #' time_point = 9, |
||
| 384 | +223 |
- }+ #' method = "both" |
||
| 385 | +224 |
-
+ #' ) %>% |
||
| 386 | +225 |
- #' Number of Available (Non-Missing Entries) in a Vector+ #' build_table(df = adtte_f) |
||
| 387 | +226 |
#' |
||
| 388 | +227 |
- #' Small utility function for better readability.+ #' @export |
||
| 389 | +228 |
- #'+ #' @order 2 |
||
| 390 | +229 |
- #' @param x (`any`)\cr vector in which to count non-missing values.+ surv_timepoint <- function(lyt, |
||
| 391 | +230 |
- #'+ vars, |
||
| 392 | +231 |
- #' @return Number of non-missing values.+ time_point, |
||
| 393 | +232 |
- #'+ is_event, |
||
| 394 | +233 |
- #' @keywords internal+ control = control_surv_timepoint(), |
||
| 395 | +234 |
- n_available <- function(x) {
+ method = c("surv", "surv_diff", "both"),
|
||
| 396 | -258x | +|||
| 235 | +
- sum(!is.na(x))+ na_str = default_na_str(), |
|||
| 397 | +236 |
- }+ nested = TRUE, |
||
| 398 | +237 |
-
+ ..., |
||
| 399 | +238 |
- #' Reapply Variable Labels+ table_names_suffix = "", |
||
| 400 | +239 |
- #'+ var_labels = "Time", |
||
| 401 | +240 |
- #' This is a helper function that is used in tests.+ show_labels = "visible", |
||
| 402 | +241 |
- #'+ .stats = c( |
||
| 403 | +242 |
- #' @param x (`vector`)\cr vector of elements that needs new labels.+ "pt_at_risk", "event_free_rate", "rate_ci", |
||
| 404 | +243 |
- #' @param varlabels (`character`)\cr vector of labels for `x`.+ "rate_diff", "rate_diff_ci", "ztest_pval" |
||
| 405 | +244 |
- #' @param ... further parameters to be added to the list.+ ), |
||
| 406 | +245 |
- #'+ .formats = NULL, |
||
| 407 | +246 |
- #' @return `x` with variable labels reapplied.+ .labels = NULL, |
||
| 408 | +247 |
- #'+ .indent_mods = if (method == "both") {
|
||
| 409 | -+ | |||
| 248 | +2x |
- #' @export+ c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L) |
||
| 410 | +249 |
- reapply_varlabels <- function(x, varlabels, ...) {
+ } else {
|
||
| 411 | -10x | +250 | +4x |
- named_labels <- c(as.list(varlabels), list(...))+ c(rate_diff_ci = 1L, ztest_pval = 1L) |
| 412 | -10x | +|||
| 251 | +
- formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)+ }) {
|
|||
| 413 | -10x | +252 | +6x |
- x+ method <- match.arg(method) |
| 414 | -+ | |||
| 253 | +6x |
- }+ checkmate::assert_string(table_names_suffix) |
||
| 415 | +254 | |||
| 416 | -+ | |||
| 255 | +6x |
- # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show+ extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...) |
||
| 417 | +256 |
- clogit_with_tryCatch <- function(formula, data, ...) { # nolint
+
|
||
| 418 | -30x | +257 | +6x |
- tryCatch(+ f <- list( |
| 419 | -30x | +258 | +6x |
- survival::clogit(formula = formula, data = data, ...),+ surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
| 420 | -30x | +259 | +6x |
- error = function(e) stop("model not built successfully with survival::clogit")
+ surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
| 421 | +260 |
) |
||
| 422 | -- |
- }- |
-
| 1 | -+ | ||
| 261 | +6x |
- #' Subgroup Treatment Effect Pattern (STEP) Fit for Binary (Response) Outcome+ .stats <- h_split_param(.stats, .stats, f = f) |
|
| 2 | -+ | ||
| 262 | +6x |
- #'+ .formats <- h_split_param(.formats, names(.formats), f = f) |
|
| 3 | -+ | ||
| 263 | +6x |
- #' @description `r lifecycle::badge("stable")`
+ .labels <- h_split_param(.labels, names(.labels), f = f) |
|
| 4 | -+ | ||
| 264 | +6x |
- #'+ .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f) |
|
| 5 | +265 |
- #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary+ |
|
| 6 | -+ | ||
| 266 | +6x |
- #' (response) outcome. The treatment arm variable must have exactly 2 levels,+ afun_surv <- make_afun( |
|
| 7 | -+ | ||
| 267 | +6x |
- #' where the first one is taken as reference and the estimated odds ratios are+ a_surv_timepoint, |
|
| 8 | -+ | ||
| 268 | +6x |
- #' for the comparison of the second level vs. the first one.+ .stats = .stats$surv, |
|
| 9 | -+ | ||
| 269 | +6x |
- #'+ .formats = .formats$surv, |
|
| 10 | -+ | ||
| 270 | +6x |
- #' The (conditional) logistic regression model which is fit is:+ .labels = .labels$surv, |
|
| 11 | -+ | ||
| 271 | +6x |
- #'+ .indent_mods = .indent_mods$surv |
|
| 12 | +272 |
- #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ ) |
|
| 13 | +273 |
- #'+ |
|
| 14 | -+ | ||
| 274 | +6x |
- #' where `degree` is specified by `control_step()`.+ afun_surv_diff <- make_afun( |
|
| 15 | -+ | ||
| 275 | +6x |
- #'+ a_surv_timepoint_diff, |
|
| 16 | -+ | ||
| 276 | +6x |
- #' @inheritParams argument_convention+ .stats = .stats$surv_diff, |
|
| 17 | -+ | ||
| 277 | +6x |
- #' @param variables (named `list` of `character`)\cr list of analysis variables:+ .formats = .formats$surv_diff, |
|
| 18 | -+ | ||
| 278 | +6x |
- #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`.+ .labels = .labels$surv_diff, |
|
| 19 | -+ | ||
| 279 | +6x |
- #' @param control (named `list`)\cr combined control list from [control_step()]+ .indent_mods = .indent_mods$surv_diff |
|
| 20 | +280 |
- #' and [control_logistic()].+ ) |
|
| 21 | +281 |
- #'+ |
|
| 22 | -+ | ||
| 282 | +6x |
- #' @return A matrix of class `step`. The first part of the columns describe the+ time_point <- extra_args$time_point |
|
| 23 | +283 |
- #' subgroup intervals used for the biomarker variable, including where the+ |
|
| 24 | -+ | ||
| 284 | +6x |
- #' center of the intervals are and their bounds. The second part of the+ for (i in seq_along(time_point)) {
|
|
| 25 | -+ | ||
| 285 | +6x |
- #' columns contain the estimates for the treatment arm comparison.+ extra_args[["time_point"]] <- time_point[i] |
|
| 26 | +286 |
- #'+ |
|
| 27 | -+ | ||
| 287 | +6x |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ if (method %in% c("surv", "both")) {
|
|
| 28 | -+ | ||
| 288 | +4x |
- #'+ lyt <- analyze( |
|
| 29 | -+ | ||
| 289 | +4x |
- #' @seealso [control_step()] and [control_logistic()] for the available+ lyt, |
|
| 30 | -+ | ||
| 290 | +4x |
- #' customization options.+ vars, |
|
| 31 | -+ | ||
| 291 | +4x |
- #'+ var_labels = paste(time_point[i], var_labels), |
|
| 32 | -+ | ||
| 292 | +4x |
- #' @examples+ table_names = paste0("surv_", time_point[i], table_names_suffix),
|
|
| 33 | -+ | ||
| 293 | +4x |
- #' # Testing dataset with just two treatment arms.+ show_labels = show_labels, |
|
| 34 | -+ | ||
| 294 | +4x |
- #' library(survival)+ afun = afun_surv, |
|
| 35 | -+ | ||
| 295 | +4x |
- #' library(dplyr)+ na_str = na_str, |
|
| 36 | -+ | ||
| 296 | +4x |
- #'+ nested = nested, |
|
| 37 | -+ | ||
| 297 | +4x |
- #' adrs_f <- tern_ex_adrs %>%+ extra_args = extra_args |
|
| 38 | +298 |
- #' filter(+ ) |
|
| 39 | +299 |
- #' PARAMCD == "BESRSPI",+ } |
|
| 40 | +300 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+
|
|
| 41 | -+ | ||
| 301 | +6x |
- #' ) %>%+ if (method %in% c("surv_diff", "both")) {
|
|
| 42 | -+ | ||
| 302 | +4x |
- #' mutate(+ lyt <- analyze( |
|
| 43 | -+ | ||
| 303 | +4x |
- #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations.+ lyt, |
|
| 44 | -+ | ||
| 304 | +4x |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ vars, |
|
| 45 | -+ | ||
| 305 | +4x |
- #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ var_labels = paste(time_point[i], var_labels), |
|
| 46 | -+ | ||
| 306 | +4x |
- #' SEX = factor(SEX)+ table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
|
|
| 47 | -+ | ||
| 307 | +4x |
- #' )+ show_labels = ifelse(method == "both", "hidden", show_labels), |
|
| 48 | -+ | ||
| 308 | +4x |
- #'+ afun = afun_surv_diff, |
|
| 49 | -+ | ||
| 309 | +4x |
- #' variables <- list(+ na_str = na_str, |
|
| 50 | -+ | ||
| 310 | +4x |
- #' arm = "ARM",+ nested = nested, |
|
| 51 | -+ | ||
| 311 | +4x |
- #' biomarker = "BMRKR1",+ extra_args = extra_args |
|
| 52 | +312 |
- #' covariates = "AGE",+ ) |
|
| 53 | +313 |
- #' response = "RSP"+ } |
|
| 54 | +314 |
- #' )+ } |
|
| 55 | -+ | ||
| 315 | +6x |
- #'+ lyt |
|
| 56 | +316 |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ } |
| 57 | +1 |
- #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those.+ #' Control Function for Subgroup Treatment Effect Pattern (STEP) Calculations |
||
| 58 | +2 |
- #' step_matrix <- fit_rsp_step(+ #' |
||
| 59 | +3 |
- #' variables = variables,+ #' @description `r lifecycle::badge("stable")`
|
||
| 60 | +4 |
- #' data = adrs_f,+ #' |
||
| 61 | +5 |
- #' control = c(control_logistic(), control_step(bandwidth = 0.9))+ #' This is an auxiliary function for controlling arguments for STEP calculations. |
||
| 62 | +6 |
- #' )+ #' |
||
| 63 | +7 |
- #' dim(step_matrix)+ #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which |
||
| 64 | +8 |
- #' head(step_matrix)+ #' could be used to infer `bandwidth`, see below. |
||
| 65 | +9 |
- #'+ #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to |
||
| 66 | +10 |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data |
||
| 67 | +11 |
- #' # models. Or specify different logistic regression options, including confidence level.+ #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly |
||
| 68 | +12 |
- #' step_matrix2 <- fit_rsp_step(+ #' distributed. |
||
| 69 | +13 |
- #' variables = variables,+ #' @param bandwidth (`number` or `NULL`)\cr indicating the bandwidth of each window. |
||
| 70 | +14 |
- #' data = adrs_f,+ #' Depending on the argument `use_percentile`, it can be either the length of actual-value |
||
| 71 | +15 |
- #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = NULL, degree = 1))+ #' windows on the real biomarker scale, or percentage windows. |
||
| 72 | +16 |
- #' )+ #' If `use_percentile = TRUE`, it should be a number between 0 and 1. |
||
| 73 | +17 |
- #'+ #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted. |
||
| 74 | +18 |
- #' # Use a global constant model. This is helpful as a reference for the subgroup models.+ #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker` |
||
| 75 | +19 |
- #' step_matrix3 <- fit_rsp_step(+ #' variable for actual-value windows. |
||
| 76 | +20 |
- #' variables = variables,+ #' @param degree (`count`)\cr the degree of polynomial function of the biomarker as an interaction term |
||
| 77 | +21 |
- #' data = adrs_f,+ #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable |
||
| 78 | +22 |
- #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L))+ #' is not included in the model fitted in each biomarker window. |
||
| 79 | +23 |
- #' )+ #' @param num_points (`count`)\cr the number of points at which the hazard ratios are estimated. The |
||
| 80 | +24 |
- #'+ #' smallest number is 2. |
||
| 81 | +25 |
- #' # It is also possible to use strata, i.e. use conditional logistic regression models.+ #' |
||
| 82 | +26 |
- #' variables2 <- list(+ #' @return A list of components with the same names as the arguments, except `biomarker` which is |
||
| 83 | +27 |
- #' arm = "ARM",+ #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested. |
||
| 84 | +28 |
- #' biomarker = "BMRKR1",+ #' |
||
| 85 | +29 |
- #' covariates = "AGE",+ #' @examples |
||
| 86 | +30 |
- #' response = "RSP",+ #' # Provide biomarker values and request actual values to be used, |
||
| 87 | +31 |
- #' strata = c("STRATA1", "STRATA2")
+ #' # so that bandwidth is chosen from range. |
||
| 88 | +32 |
- #' )+ #' control_step(biomarker = 1:10, use_percentile = FALSE) |
||
| 89 | +33 |
#' |
||
| 90 | +34 |
- #' step_matrix4 <- fit_rsp_step(+ #' # Use a global model with quadratic biomarker interaction term. |
||
| 91 | +35 |
- #' variables = variables2,+ #' control_step(bandwidth = NULL, degree = 2) |
||
| 92 | +36 |
- #' data = adrs_f,+ #' |
||
| 93 | +37 |
- #' control = c(control_logistic(), control_step(bandwidth = NULL))+ #' # Reduce number of points to be used. |
||
| 94 | +38 |
- #' )+ #' control_step(num_points = 10) |
||
| 95 | +39 |
#' |
||
| 96 | +40 |
#' @export |
||
| 97 | +41 |
- fit_rsp_step <- function(variables,+ control_step <- function(biomarker = NULL, |
||
| 98 | +42 |
- data,+ use_percentile = TRUE, |
||
| 99 | +43 |
- control = c(control_step(), control_logistic())) {
+ bandwidth, |
||
| 100 | -5x | +|||
| 44 | +
- assert_df_with_variables(data, variables)+ degree = 0L, |
|||
| 101 | -5x | +|||
| 45 | +
- checkmate::assert_list(control, names = "named")+ num_points = 39L) {
|
|||
| 102 | -5x | +46 | +31x |
- data <- data[!is.na(data[[variables$biomarker]]), ]+ checkmate::assert_numeric(biomarker, null.ok = TRUE) |
| 103 | -5x | +47 | +30x |
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ checkmate::assert_flag(use_percentile) |
| 104 | -5x | +48 | +30x |
- interval_center <- window_sel$interval[, "Interval Center"]+ checkmate::assert_int(num_points, lower = 2) |
| 105 | -5x | +49 | +29x |
- form <- h_step_rsp_formula(variables = variables, control = control)+ checkmate::assert_count(degree) |
| 106 | -5x | +|||
| 50 | +
- estimates <- if (is.null(control$bandwidth)) {
+
|
|||
| 107 | -1x | +51 | +29x |
- h_step_rsp_est(+ if (missing(bandwidth)) {
|
| 108 | -1x | +|||
| 52 | +
- formula = form,+ # Infer bandwidth |
|||
| 109 | -1x | +53 | +21x |
- data = data,+ bandwidth <- if (use_percentile) {
|
| 110 | -1x | +54 | +18x |
- variables = variables,+ 0.25 |
| 111 | -1x | +55 | +21x |
- x = interval_center,+ } else if (!is.null(biomarker)) {
|
| 112 | -1x | +56 | +3x |
- control = control+ diff(range(biomarker, na.rm = TRUE)) / 4 |
| 113 | +57 |
- )+ } else {
|
||
| 114 | -+ | |||
| 58 | +! |
- } else {
+ NULL |
||
| 115 | -4x | +|||
| 59 | +
- tmp <- mapply(+ } |
|||
| 116 | -4x | +|||
| 60 | +
- FUN = h_step_rsp_est,+ } else {
|
|||
| 117 | -4x | +|||
| 61 | +
- x = interval_center,+ # Check bandwidth |
|||
| 118 | -4x | +62 | +8x |
- subset = as.list(as.data.frame(window_sel$sel)),+ if (!is.null(bandwidth)) {
|
| 119 | -4x | +63 | +5x |
- MoreArgs = list(+ if (use_percentile) {
|
| 120 | +64 | 4x |
- formula = form,+ assert_proportion_value(bandwidth) |
|
| 121 | -4x | +|||
| 65 | +
- data = data,+ } else {
|
|||
| 122 | -4x | +66 | +1x |
- variables = variables,+ checkmate::assert_scalar(bandwidth) |
| 123 | -4x | -
- control = control- |
- ||
| 124 | -+ | 67 | +1x |
- )+ checkmate::assert_true(bandwidth > 0) |
| 125 | +68 |
- )+ } |
||
| 126 | +69 |
- # Maybe we find a more elegant solution than this.- |
- ||
| 127 | -4x | -
- rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
- |
- ||
| 128 | -4x | -
- t(tmp)+ } |
||
| 129 | +70 |
} |
||
| 130 | -5x | -
- result <- cbind(window_sel$interval, estimates)- |
- ||
| 131 | -5x | +71 | +28x |
- structure(+ list( |
| 132 | -5x | +72 | +28x |
- result,+ use_percentile = use_percentile, |
| 133 | -5x | +73 | +28x |
- class = c("step", "matrix"),
+ bandwidth = bandwidth, |
| 134 | -5x | +74 | +28x |
- variables = variables,+ degree = as.integer(degree), |
| 135 | -5x | +75 | +28x |
- control = control+ num_points = as.integer(num_points) |
| 136 | +76 |
) |
||
| 137 | +77 |
}@@ -90085,14 +91379,14 @@ tern coverage - 90.46% |
| 1 |
- #' Helper Function to create a new `SMQ` variable in `ADAE` by stacking `SMQ` and/or `CQ` records.+ #' Line plot with the optional table |
|||
| 5 |
- #' Helper Function to create a new `SMQ` variable in `ADAE` that consists of all adverse events belonging to+ #' Line plot with the optional table. |
|||
| 6 |
- #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events+ #' |
|||
| 7 |
- #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
|||
| 8 |
- #' done with [df_explicit_na()] to have the desired output.+ #' @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 |
- #' @inheritParams argument_convention+ #' @param variables (named `character` vector) of variable names in `df` data set. Details are: |
|||
| 11 |
- #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries.+ #' * `x` (`character`)\cr name of x-axis variable. |
|||
| 12 |
- #' @param smq_varlabel (`string`)\cr a label for the new variable created.+ #' * `y` (`character`)\cr name of y-axis variable. |
|||
| 13 |
- #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created.+ #' * `group_var` (`character`)\cr name of grouping variable (or strata), i.e. treatment arm. |
|||
| 14 |
- #' @param aag_summary (`data.frame`)\cr containing the `SMQ` baskets and the levels of interest for the final `SMQ`+ #' Can be `NA` to indicate lack of groups. |
|||
| 15 |
- #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset.+ #' * `subject_var` (`character`)\cr name of subject variable. Only applies if `group_var` is |
|||
| 16 |
- #' The two columns of this dataset should be named `basket` and `basket_name`.+ #' not NULL. |
|||
| 17 |
- #'+ #' * `paramcd` (`character`)\cr name of the variable for parameter's code. Used for y-axis label and plot's subtitle. |
|||
| 18 |
- #' @return `data.frame` with variables in `keys` taken from `df` and new variable `SMQ` containing+ #' Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle. |
|||
| 19 |
- #' records belonging to the baskets selected via the `baskets` argument.+ #' * `y_unit` (`character`)\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 |
- #' @examples+ #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints. |
|||
| 22 |
- #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na()+ #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`, |
|||
| 23 |
- #' h_stack_by_baskets(df = adae)+ #' and be of a `double` or `numeric` type vector of length one. |
|||
| 24 |
- #'+ #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals. |
|||
| 25 |
- #' aag <- data.frame(+ #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`, |
|||
| 26 |
- #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
+ #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be |
|||
| 27 |
- #' REFNAME = c(+ #' added to the plot. |
|||
| 28 |
- #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi",+ #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names |
|||
| 29 |
- #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi"+ #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of |
|||
| 30 |
- #' ),+ #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting |
|||
| 31 |
- #' SCOPE = c("", "", "BROAD", "BROAD"),
+ #' `interval = NULL`. |
|||
| 32 |
- #' stringsAsFactors = FALSE+ #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot. |
|||
| 33 |
- #' )+ #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`. |
|||
| 34 |
- #'+ #' @param sfun (`closure`)\cr the function to compute the values of required statistics. It must return a named `list` |
|||
| 35 |
- #' basket_name <- character(nrow(aag))+ #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`, |
|||
| 36 |
- #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
+ #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed. |
|||
| 37 |
- #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
+ #' @param ... optional arguments to `sfun`. |
|||
| 38 |
- #' basket_name[cq_pos] <- aag$REFNAME[cq_pos]+ #' @param mid_type (`character`)\cr controls the type of the `mid` plot, it can be point (`p`), line (`l`), |
|||
| 39 |
- #' basket_name[smq_pos] <- paste0(+ #' or point and line (`pl`). |
|||
| 40 |
- #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
+ #' @param mid_point_size (`integer` or `double`)\cr controls the font size of the point for `mid` plot. |
|||
| 41 |
- #' )+ #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of |
|||
| 42 |
- #'+ #' a call to a position adjustment function. |
|||
| 43 |
- #' aag_summary <- data.frame(+ #' @param legend_title (`character` string)\cr legend title. |
|||
| 44 |
- #' basket = aag$NAMVAR,+ #' @param legend_position (`character`)\cr the position of the plot legend (`none`, `left`, `right`, `bottom`, `top`, |
|||
| 45 |
- #' basket_name = basket_name,+ #' or two-element numeric vector). |
|||
| 46 |
- #' stringsAsFactors = TRUE+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
|||
| 47 |
- #' )+ #' @param x_lab (`character`)\cr x-axis label. If equal to `NULL`, then no label will be added. |
|||
| 48 |
- #'+ #' @param y_lab (`character`)\cr y-axis label. If equal to `NULL`, then no label will be added. |
|||
| 49 |
- #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)+ #' @param y_lab_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to the |
|||
| 50 |
- #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ #' y-axis label `y_lab`? |
|||
| 51 |
- #'+ #' @param y_lab_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the y-axis |
|||
| 52 |
- #' h_stack_by_baskets(+ #' label `y_lab`? |
|||
| 53 |
- #' df = adae,+ #' @param title (`character`)\cr plot title. |
|||
| 54 |
- #' aag_summary = NULL,+ #' @param subtitle (`character`)\cr plot subtitle. |
|||
| 55 |
- #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
+ #' @param subtitle_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to |
|||
| 56 |
- #' baskets = "SMQ01NAM"+ #' the plot's subtitle `subtitle`? |
|||
| 57 |
- #' )+ #' @param subtitle_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the |
|||
| 58 |
- #'+ #' plot's subtitle `subtitle`? |
|||
| 59 |
- #' @export+ #' @param caption (`character`)\cr optional caption below the plot. |
|||
| 60 |
- h_stack_by_baskets <- function(df,+ #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the |
|||
| 61 |
- baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
+ #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format` |
|||
| 62 |
- smq_varlabel = "Standardized MedDRA Query",+ #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function. |
|||
| 63 |
- keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
+ #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table |
|||
| 64 |
- aag_summary = NULL,+ #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function. |
|||
| 65 |
- na_level = lifecycle::deprecated(),+ #' @param table_font_size (`integer` or `double`)\cr controls the font size of values in the table. |
|||
| 66 |
- na_str = "<Missing>") {
+ #' @param newpage (`logical`)\cr should plot be drawn on new page? |
|||
| 67 | -5x | +
- if (lifecycle::is_present(na_level)) {
+ #' @param col (`character`)\cr colors. |
||
| 68 | -! | +
- lifecycle::deprecate_warn("0.9.1", "h_stack_by_baskets(na_level)", "h_stack_by_baskets(na_str)")
+ #' |
||
| 69 | -! | +
- na_str <- na_level+ #' @return A `ggplot` line plot (and statistics table if applicable). |
||
| 70 |
- }+ #' |
|||
| 71 |
-
+ #' @examples |
|||
| 72 | -5x | +
- smq_nam <- baskets[startsWith(baskets, "SMQ")]+ #' library(nestcolor) |
||
| 73 |
- # SC corresponding to NAM+ #' |
|||
| 74 | -5x | +
- smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)+ #' adsl <- tern_ex_adsl |
||
| 75 | -5x | +
- smq <- stats::setNames(smq_sc, smq_nam)+ #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING") |
||
| 76 |
-
+ #' adlb$AVISIT <- droplevels(adlb$AVISIT) |
|||
| 77 | -5x | +
- checkmate::assert_character(baskets)+ #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) |
||
| 78 | -5x | +
- checkmate::assert_string(smq_varlabel)+ #' |
||
| 79 | -5x | +
- checkmate::assert_data_frame(df)+ #' # Mean with CI |
||
| 80 | -5x | +
- checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))+ #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:") |
||
| 81 | -4x | +
- checkmate::assert_true(all(endsWith(baskets, "NAM")))+ #' |
||
| 82 | -3x | +
- checkmate::assert_subset(baskets, names(df))+ #' # Mean with CI, no stratification with group_var |
||
| 83 | -3x | +
- checkmate::assert_subset(keys, names(df))+ #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA)) |
||
| 84 | -3x | +
- checkmate::assert_subset(smq_sc, names(df))+ #' |
||
| 85 | -3x | +
- checkmate::assert_string(na_str)+ #' # Mean, upper whisker of CI, no group_var(strata) counts N |
||
| 86 |
-
+ #' g_lineplot( |
|||
| 87 | -3x | +
- if (!is.null(aag_summary)) {
+ #' adlb, |
||
| 88 | -1x | +
- assert_df_with_variables(+ #' whiskers = "mean_ci_upr", |
||
| 89 | -1x | +
- df = aag_summary,+ #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit" |
||
| 90 | -1x | +
- variables = list(val = c("basket", "basket_name"))
+ #' ) |
||
| 91 |
- )+ #' |
|||
| 92 |
- # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.+ #' # Median with CI |
|||
| 93 |
- # Honestly, I think those should completely match. Target baskets should be the same.+ #' g_lineplot( |
|||
| 94 | -1x | +
- if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
+ #' adlb, |
||
| 95 | -! | +
- warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
+ #' adsl, |
||
| 96 |
- }+ #' mid = "median", |
|||
| 97 |
- }+ #' interval = "median_ci", |
|||
| 98 |
-
+ #' whiskers = c("median_ci_lwr", "median_ci_upr"),
|
|||
| 99 | -3x | +
- var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)+ #' title = "Plot of Median and 95% Confidence Limits by Visit" |
||
| 100 |
-
+ #' ) |
|||
| 101 |
- # convert `na_str` records from baskets to NA for the later loop and from wide to long steps+ #' |
|||
| 102 | -3x | +
- df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA+ #' # Mean, +/- SD |
||
| 103 |
-
+ #' g_lineplot(adlb, adsl, |
|||
| 104 | -3x | +
- if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
+ #' interval = "mean_sdi", |
||
| 105 | -1x | +
- df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty dataframe keeping all factor levels+ #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
|
||
| 106 |
- } else {
+ #' title = "Plot of Median +/- SD by Visit" |
|||
| 107 |
- # Concatenate SMQxxxNAM with corresponding SMQxxxSC+ #' ) |
|||
| 108 | -2x | +
- df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]+ #' |
||
| 109 |
-
+ #' # Mean with CI plot with stats table |
|||
| 110 | -2x | +
- for (nam in names(smq)) {
+ #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
|
||
| 111 | -4x | +
- sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ #' |
||
| 112 | -4x | +
- nam_notna <- !is.na(df[[nam]])+ #' # Mean with CI, table and customized confidence level |
||
| 113 | -4x | +
- new_colname <- paste(nam, sc, sep = "_")+ #' g_lineplot( |
||
| 114 | -4x | +
- df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
+ #' adlb, |
||
| 115 |
- }+ #' adsl, |
|||
| 116 |
-
+ #' table = c("n", "mean", "mean_ci"),
|
|||
| 117 | -2x | +
- df_cnct$unique_id <- seq(1, nrow(df_cnct))+ #' control = control_analyze_vars(conf_level = 0.80), |
||
| 118 | -2x | +
- var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))]+ #' title = "Plot of Mean and 80% Confidence Limits by Visit" |
||
| 119 |
- # have to convert df_cnct from tibble to dataframe+ #' ) |
|||
| 120 |
- # as it throws a warning otherwise about rownames.+ #' |
|||
| 121 |
- # tibble do not support rownames and reshape creates rownames+ #' # Mean with CI, table, filtered data |
|||
| 122 |
-
+ #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE") |
|||
| 123 | -2x | +
- df_long <- stats::reshape(+ #' g_lineplot(adlb_f, table = c("n", "mean"))
|
||
| 124 | -2x | +
- data = as.data.frame(df_cnct),+ #' |
||
| 125 | -2x | +
- varying = var_cols,+ #' @export |
||
| 126 | -2x | +
- v.names = "SMQ",+ g_lineplot <- function(df, |
||
| 127 | -2x | ++ |
+ alt_counts_df = NULL,+ |
+ |
| 128 | ++ |
+ variables = control_lineplot_vars(),+ |
+ ||
| 129 | ++ |
+ mid = "mean",+ |
+ ||
| 130 | ++ |
+ interval = "mean_ci",+ |
+ ||
| 131 | ++ |
+ whiskers = c("mean_ci_lwr", "mean_ci_upr"),
+ |
+ ||
| 132 | ++ |
+ table = NULL,+ |
+ ||
| 133 | ++ |
+ sfun = tern::s_summary,+ |
+ ||
| 134 | ++ |
+ ...,+ |
+ ||
| 135 | ++ |
+ mid_type = "pl",+ |
+ ||
| 136 | ++ |
+ mid_point_size = 2,+ |
+ ||
| 137 | ++ |
+ position = ggplot2::position_dodge(width = 0.4),+ |
+ ||
| 138 | ++ |
+ legend_title = NULL,+ |
+ ||
| 139 | ++ |
+ legend_position = "bottom",+ |
+ ||
| 140 | ++ |
+ ggtheme = nestcolor::theme_nest(),+ |
+ ||
| 141 | ++ |
+ x_lab = obj_label(df[[variables[["x"]]]]),+ |
+ ||
| 142 | ++ |
+ y_lab = NULL,+ |
+ ||
| 143 | ++ |
+ y_lab_add_paramcd = TRUE,+ |
+ ||
| 144 | ++ |
+ y_lab_add_unit = TRUE,+ |
+ ||
| 145 | ++ |
+ title = "Plot of Mean and 95% Confidence Limits by Visit",+ |
+ ||
| 146 | ++ |
+ subtitle = "",+ |
+ ||
| 147 | ++ |
+ subtitle_add_paramcd = TRUE,+ |
+ ||
| 148 | ++ |
+ subtitle_add_unit = TRUE,+ |
+ ||
| 149 | ++ |
+ caption = NULL,+ |
+ ||
| 150 | ++ |
+ table_format = summary_formats(),+ |
+ ||
| 151 | ++ |
+ table_labels = summary_labels(),+ |
+ ||
| 152 | ++ |
+ table_font_size = 3,+ |
+ ||
| 153 | ++ |
+ newpage = TRUE,+ |
+ ||
| 154 | ++ |
+ col = NULL) {
+ |
+ ||
| 155 | +3x | +
+ checkmate::assert_character(variables, any.missing = TRUE)+ |
+ ||
| 156 | +3x | +
+ checkmate::assert_character(mid, null.ok = TRUE)+ |
+ ||
| 157 | +3x | +
+ checkmate::assert_character(interval, null.ok = TRUE)+ |
+ ||
| 158 | +3x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+ ||
| 159 | ++ | + + | +||
| 160 | +3x | +
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+ ||
| 161 | +3x | +
+ checkmate::assert_string(subtitle, null.ok = TRUE)+ |
+ ||
| 162 | +
- idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ |
|||
| 128 | -2x | +163 | +3x |
- direction = "long",+ if (is.character(interval)) {
|
| 129 | -2x | +164 | +3x |
- new.row.names = seq(prod(length(var_cols), nrow(df_cnct)))+ checkmate::assert_vector(whiskers, min.len = 0, max.len = 2) |
| 130 | +165 |
- )+ } |
||
| 131 | +166 | |||
| 132 | -2x | +167 | +3x |
- df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
+ if (length(whiskers) == 1) {
|
| 133 | -2x | +|||
| 168 | +! |
- df_long$SMQ <- as.factor(df_long$SMQ)+ checkmate::assert_character(mid) |
||
| 134 | +169 |
} |
||
| 135 | +170 | |||
| 136 | +171 | 3x |
- smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str)+ if (is.character(mid)) {
|
|
| 137 | -+ | |||
| 172 | +3x |
-
+ checkmate::assert_scalar(mid_type) |
||
| 138 | +173 | 3x |
- if (!is.null(aag_summary)) {
+ checkmate::assert_subset(mid_type, c("pl", "p", "l"))
|
|
| 139 | +174 |
- # A warning in case there is no match between df and aag_summary records+ } |
||
| 140 | -1x | +|||
| 175 | +
- if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
+
|
|||
| 141 | -1x | +176 | +3x |
- warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
+ x <- variables[["x"]] |
| 142 | -+ | |||
| 177 | +3x |
- }+ y <- variables[["y"]] |
||
| 143 | -1x | +178 | +3x |
- df_long[["SMQ"]] <- factor(+ paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables |
| 144 | -1x | +179 | +3x |
- df_long[["SMQ"]],+ y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables |
| 145 | -1x | +180 | +3x |
- levels = sort(+ if (is.na(variables["group_var"])) {
|
| 146 | -1x | +|||
| 181 | +! |
- c(+ group_var <- NULL # NULL if group_var == NA or it is not in variables |
||
| 147 | -1x | +|||
| 182 | +
- smq_levels,+ } else {
|
|||
| 148 | -1x | +183 | +3x |
- setdiff(unique(aag_summary$basket_name), smq_levels)+ group_var <- variables[["group_var"]] |
| 149 | -+ | |||
| 184 | +3x |
- )+ subject_var <- variables[["subject_var"]] |
||
| 150 | +185 |
- )+ } |
||
| 151 | -+ | |||
| 186 | +3x |
- )+ checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE) |
||
| 152 | -+ | |||
| 187 | +3x |
- } else {
+ checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE) |
||
| 153 | -2x | +188 | +3x |
- all_na_basket_flag <- vapply(df[, baskets], function(x) {
+ if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
|
| 154 | -6x | +189 | +3x |
- all(is.na(x))+ checkmate::assert_false(is.na(paramcd)) |
| 155 | -2x | +190 | +3x |
- }, FUN.VALUE = logical(1))+ checkmate::assert_scalar(unique(df[[paramcd]])) |
| 156 | -2x | +|||
| 191 | +
- all_na_basket <- baskets[all_na_basket_flag]+ } |
|||
| 157 | +192 | |||
| 158 | -2x | +193 | +3x |
- df_long[["SMQ"]] <- factor(+ checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE) |
| 159 | -2x | +194 | +3x |
- df_long[["SMQ"]],+ checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE) |
| 160 | -2x | +195 | +3x |
- levels = sort(c(smq_levels, all_na_basket))+ if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
+ |
+
| 196 | +3x | +
+ checkmate::assert_false(is.na(y_unit))+ |
+ ||
| 197 | +3x | +
+ checkmate::assert_scalar(unique(df[[y_unit]])) |
||
| 161 | +198 |
- )+ } |
||
| 162 | +199 |
- }+ |
||
| 163 | +200 | 3x |
- formatters::var_labels(df_long) <- var_labels+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
|
|
| 164 | +201 | 3x |
- tibble::tibble(df_long)+ checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]])) |
|
| 165 | +202 |
- }+ } |
| 1 | +203 |
- #' Occurrence Counts+ |
||
| 2 | +204 |
- #'+ ####################################### | |
||
| 3 | +205 |
- #' @description `r lifecycle::badge("stable")`
+ # ---- Compute required statistics ---- |
||
| 4 | +206 |
- #'+ ####################################### | |
||
| 5 | -+ | |||
| 207 | +3x |
- #' Functions for analyzing frequencies and fractions of occurrences for patients with occurrence+ if (!is.null(group_var)) {
|
||
| 6 | -+ | |||
| 208 | +3x |
- #' data. Primary analysis variables are the dictionary terms. All occurrences are counted for total+ df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors |
||
| 7 | +209 |
- #' counts. Multiple occurrences within patient at the lowest term level displayed in the table are+ } else {
|
||
| 8 | -+ | |||
| 210 | +! |
- #' counted only once.+ df_grp <- tidyr::expand(df, NULL, .data[[x]]) |
||
| 9 | +211 |
- #'+ } |
||
| 10 | -+ | |||
| 212 | +3x |
- #' @inheritParams argument_convention+ df_grp <- df_grp %>% |
||
| 11 | -+ | |||
| 213 | +3x |
- #' @param drop (`flag`)\cr should non appearing occurrence levels be dropped from the resulting table.+ dplyr::full_join(y = df[, c(group_var, x, y)], by = c(group_var, x), multiple = "all") %>% |
||
| 12 | -+ | |||
| 214 | +3x |
- #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically.+ dplyr::group_by_at(c(group_var, x)) |
||
| 13 | +215 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_occurrences")`
+
|
||
| 14 | -+ | |||
| 216 | +3x |
- #' to see available statistics for this function.+ df_stats <- df_grp %>% |
||
| 15 | -+ | |||
| 217 | +3x |
- #'+ dplyr::summarise( |
||
| 16 | -+ | |||
| 218 | +3x |
- #' @note By default, occurrences which don't appear in a given row split are dropped from the table and+ data.frame(t(do.call(c, unname(sfun(.data[[y]], ...)[c(mid, interval)])))), |
||
| 17 | -+ | |||
| 219 | +3x |
- #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout+ .groups = "drop" |
||
| 18 | +220 |
- #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would+ ) |
||
| 19 | +221 |
- #' like to show all occurrences.+ |
||
| 20 | -+ | |||
| 222 | +3x |
- #'+ df_stats <- df_stats[!is.na(df_stats[[mid]]), ] |
||
| 21 | +223 |
- #' @examples+ |
||
| 22 | +224 |
- #' library(dplyr)+ # add number of objects N in group_var (strata) |
||
| 23 | -+ | |||
| 225 | +3x |
- #' df <- data.frame(+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
|
||
| 24 | -+ | |||
| 226 | +3x |
- #' USUBJID = as.character(c(+ strata_N <- paste0(group_var, "_N") # nolint |
||
| 25 | +227 |
- #' 1, 1, 2, 4, 4, 4,+ |
||
| 26 | -+ | |||
| 228 | +3x |
- #' 6, 6, 6, 7, 7, 8+ 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 |
||
| 27 | -+ | |||
| 229 | +3x |
- #' )),+ colnames(df_N) <- c(group_var, "N") # nolint |
||
| 28 | -+ | |||
| 230 | +3x |
- #' MHDECOD = c(+ df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint |
||
| 29 | +231 |
- #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",+ |
||
| 30 | +232 |
- #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"+ # strata_N should not be in clonames(df_stats) |
||
| 31 | -+ | |||
| 233 | +3x |
- #' ),+ checkmate::assert_disjunct(strata_N, colnames(df_stats)) |
||
| 32 | +234 |
- #' ARM = rep(c("A", "B"), each = 6),
+
|
||
| 33 | -+ | |||
| 235 | +3x |
- #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
+ df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var)+ |
+ ||
| 236 | +! | +
+ } else if (!is.null(group_var)) {
+ |
+ ||
| 237 | +! | +
+ strata_N <- group_var # nolint |
||
| 34 | +238 |
- #' )+ } else {
+ |
+ ||
| 239 | +! | +
+ strata_N <- NULL # nolint |
||
| 35 | +240 |
- #' df_adsl <- df %>%+ } |
||
| 36 | +241 |
- #' select(USUBJID, ARM) %>%+ |
||
| 37 | +242 |
- #' unique()+ ############################################### | |
||
| 38 | +243 |
- #'+ # ---- Prepare certain plot's properties. ---- |
||
| 39 | +244 |
- #' @name count_occurrences+ ############################################### | |
||
| 40 | +245 |
- #' @order 1+ # legend title+ |
+ ||
| 246 | +3x | +
+ if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
+ |
+ ||
| 247 | +3x | +
+ legend_title <- attr(df[[group_var]], "label") |
||
| 41 | +248 |
- NULL+ } |
||
| 42 | +249 | |||
| 43 | +250 |
- #' @describeIn count_occurrences Statistics function which counts number of patients that report an+ # y label |
||
| 44 | -+ | |||
| 251 | +3x |
- #' occurrence.+ if (!is.null(y_lab)) {
|
||
| 45 | -+ | |||
| 252 | +2x |
- #'+ if (y_lab_add_paramcd) {
|
||
| 46 | -+ | |||
| 253 | +2x |
- #' @param denom (`string`)\cr choice of denominator for patient proportions. Can be:+ y_lab <- paste(y_lab, unique(df[[paramcd]])) |
||
| 47 | +254 |
- #' - `N_col`: total number of patients in this column across rows+ } |
||
| 48 | +255 |
- #' - `n`: number of patients with any occurrences+ |
||
| 49 | -+ | |||
| 256 | +2x |
- #'+ if (y_lab_add_unit) {
|
||
| 50 | -+ | |||
| 257 | +2x |
- #' @return+ y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
|
||
| 51 | +258 |
- #' * `s_count_occurrences()` returns a list with:+ } |
||
| 52 | +259 |
- #' * `count`: list of counts with one element per occurrence.+ |
||
| 53 | -+ | |||
| 260 | +2x |
- #' * `count_fraction`: list of counts and fractions with one element per occurrence.+ y_lab <- trimws(y_lab) |
||
| 54 | +261 |
- #' * `fraction`: list of numerators and denominators with one element per occurrence.+ } |
||
| 55 | +262 |
- #'+ |
||
| 56 | +263 |
- #' @examples+ # subtitle |
||
| 57 | -+ | |||
| 264 | +3x |
- #' # Count unique occurrences per subject.+ if (!is.null(subtitle)) {
|
||
| 58 | -+ | |||
| 265 | +3x |
- #' s_count_occurrences(+ if (subtitle_add_paramcd) {
|
||
| 59 | -+ | |||
| 266 | +3x |
- #' df,+ subtitle <- paste(subtitle, unique(df[[paramcd]])) |
||
| 60 | +267 |
- #' .N_col = 4L,+ } |
||
| 61 | +268 |
- #' .df_row = df,+ |
||
| 62 | -+ | |||
| 269 | +3x |
- #' .var = "MHDECOD",+ if (subtitle_add_unit) {
|
||
| 63 | -+ | |||
| 270 | +3x |
- #' id = "USUBJID"+ subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
|
||
| 64 | +271 |
- #' )+ } |
||
| 65 | +272 |
- #'+ |
||
| 66 | -+ | |||
| 273 | +3x |
- #' @export+ subtitle <- trimws(subtitle) |
||
| 67 | +274 |
- s_count_occurrences <- function(df,+ } |
||
| 68 | +275 |
- denom = c("N_col", "n"),
+
|
||
| 69 | +276 |
- .N_col, # nolint+ ############################### | |
||
| 70 | +277 |
- .df_row,+ # ---- Build plot object. ---- |
||
| 71 | +278 |
- drop = TRUE,+ ############################### | |
||
| 72 | -+ | |||
| 279 | +3x |
- .var = "MHDECOD",+ p <- ggplot2::ggplot( |
||
| 73 | -+ | |||
| 280 | +3x |
- id = "USUBJID") {
+ data = df_stats, |
||
| 74 | -57x | +281 | +3x |
- checkmate::assert_flag(drop)+ mapping = ggplot2::aes( |
| 75 | -57x | +282 | +3x |
- assert_df_with_variables(df, list(range = .var, id = id))+ x = .data[[x]], y = .data[[mid]], |
| 76 | -57x | +283 | +3x |
- checkmate::assert_count(.N_col)+ color = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 77 | -57x | +284 | +3x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ shape = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 78 | -57x | +285 | +3x |
- checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
+ lty = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 79 | -57x | +286 | +3x |
- denom <- match.arg(denom)+ group = if (is.null(strata_N)) NULL else .data[[strata_N]] |
| 80 | +287 |
-
+ ) |
||
| 81 | -57x | +|||
| 288 | +
- occurrences <- if (drop) {
+ ) |
|||
| 82 | +289 |
- # Note that we don't try to preserve original level order here since a) that would required+ + |
+ ||
| 290 | +3x | +
+ if (!is.null(mid)) {
|
||
| 83 | +291 |
- # more time to look up in large original levels and b) that would fail for character input variable.+ # points |
||
| 84 | -46x | +292 | +3x |
- occurrence_levels <- sort(unique(.df_row[[.var]]))+ if (grepl("p", mid_type, fixed = TRUE)) {
|
| 85 | -46x | +293 | +3x |
- if (length(occurrence_levels) == 0) {
+ p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)+ |
+
| 294 | ++ |
+ }+ |
+ ||
| 295 | ++ | + + | +||
| 296 | ++ |
+ # lines+ |
+ ||
| 297 | ++ |
+ # further conditions in if are to ensure that not all of the groups consist of only one observation |
||
| 86 | -1x | +298 | +3x |
- stop(+ if (grepl("l", mid_type, fixed = TRUE) && !is.null(group_var) &&
|
| 87 | -1x | +299 | +3x |
- "no empty `.df_row` input allowed when `drop = TRUE`,",+ !all(dplyr::summarise(df_grp, count_n = dplyr::n())[["count_n"]] == 1L)) { # nolint
|
| 88 | -1x | +300 | +3x |
- " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls"+ p <- p + ggplot2::geom_line(position = position, na.rm = TRUE) |
| 89 | +301 |
- )+ } |
||
| 90 | +302 |
- }+ } |
||
| 91 | -45x | +|||
| 303 | +
- factor(df[[.var]], levels = occurrence_levels)+ |
|||
| 92 | +304 |
- } else {
+ # interval |
||
| 93 | -11x | +305 | +3x |
- df[[.var]]+ if (!is.null(interval)) {
|
| 94 | -+ | |||
| 306 | +3x |
- }+ p <- p + |
||
| 95 | -56x | +307 | +3x |
- ids <- factor(df[[id]])+ ggplot2::geom_errorbar( |
| 96 | -56x | +308 | +3x |
- dn <- switch(denom,+ ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]), |
| 97 | -56x | +309 | +3x |
- n = nlevels(ids),+ width = 0.45, |
| 98 | -56x | +310 | +3x |
- N_col = .N_col+ position = position |
| 99 | +311 |
- )+ ) |
||
| 100 | -56x | +|||
| 312 | +
- has_occurrence_per_id <- table(occurrences, ids) > 0+ |
|||
| 101 | -56x | +313 | +3x |
- n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id))+ if (length(whiskers) == 1) { # lwr or upr only; mid is then required
|
| 102 | -56x | +|||
| 314 | +
- list(+ # workaround as geom_errorbar does not provide single-direction whiskers |
|||
| 103 | -56x | +|||
| 315 | +! |
- count = n_ids_per_occurrence,+ p <- p + |
||
| 104 | -56x | +|||
| 316 | +! |
- count_fraction = lapply(+ ggplot2::geom_linerange( |
||
| 105 | -56x | +|||
| 317 | +! |
- n_ids_per_occurrence,+ data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings |
||
| 106 | -56x | +|||
| 318 | +! |
- function(i, denom) {
+ ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]), |
||
| 107 | -202x | +|||
| 319 | +! |
- if (i == 0 && denom == 0) {
+ position = position, |
||
| 108 | +320 | ! |
- c(0, 0)+ na.rm = TRUE,+ |
+ |
| 321 | +! | +
+ show.legend = FALSE |
||
| 109 | +322 |
- } else {
+ ) |
||
| 110 | -202x | +|||
| 323 | +
- c(i, i / denom)+ } |
|||
| 111 | +324 |
- }+ } |
||
| 112 | +325 |
- },+ |
||
| 113 | -56x | +326 | +3x |
- denom = dn+ p <- p + |
| 114 | -+ | |||
| 327 | +3x |
- ),+ ggplot2::scale_y_continuous(labels = scales::comma) + |
||
| 115 | -56x | +328 | +3x |
- fraction = lapply(+ ggplot2::labs( |
| 116 | -56x | +329 | +3x |
- n_ids_per_occurrence,+ title = title, |
| 117 | -56x | +330 | +3x |
- function(i, denom) c("num" = i, "denom" = denom),
+ subtitle = subtitle, |
| 118 | -56x | +331 | +3x |
- denom = dn+ caption = caption, |
| 119 | -+ | |||
| 332 | +3x | +
+ color = legend_title,+ |
+ ||
| 333 | +3x | +
+ lty = legend_title,+ |
+ ||
| 334 | +3x |
- )+ shape = legend_title, |
||
| 120 | -+ | |||
| 335 | +3x |
- )+ x = x_lab, |
||
| 121 | -+ | |||
| 336 | +3x |
- }+ y = y_lab |
||
| 122 | +337 |
-
+ ) |
||
| 123 | +338 |
- #' @describeIn count_occurrences Formatted analysis function which is used as `afun`+ |
||
| 124 | -+ | |||
| 339 | +3x |
- #' in `count_occurrences()`.+ if (!is.null(col)) {
|
||
| 125 | -+ | |||
| 340 | +! |
- #'+ p <- p + |
||
| 126 | -+ | |||
| 341 | +! |
- #' @return+ ggplot2::scale_color_manual(values = col) |
||
| 127 | +342 |
- #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
||
| 128 | +343 |
- #'+ |
||
| 129 | -+ | |||
| 344 | +3x |
- #' @examples+ if (!is.null(ggtheme)) {
|
||
| 130 | -+ | |||
| 345 | +3x |
- #' a_count_occurrences(+ p <- p + ggtheme |
||
| 131 | +346 |
- #' df,+ } else {
|
||
| 132 | -+ | |||
| 347 | +! |
- #' .N_col = 4L,+ p <- p + |
||
| 133 | -+ | |||
| 348 | +! |
- #' .df_row = df,+ ggplot2::theme_bw() + |
||
| 134 | -+ | |||
| 349 | +! |
- #' .var = "MHDECOD",+ ggplot2::theme( |
||
| 135 | -+ | |||
| 350 | +! |
- #' id = "USUBJID"+ legend.key.width = grid::unit(1, "cm"), |
||
| 136 | -+ | |||
| 351 | +! |
- #' )+ legend.position = legend_position, |
||
| 137 | -+ | |||
| 352 | +! |
- #'+ legend.direction = ifelse( |
||
| 138 | -+ | |||
| 353 | +! |
- #' @export+ legend_position %in% c("top", "bottom"),
|
||
| 139 | -+ | |||
| 354 | +! |
- a_count_occurrences <- function(df,+ "horizontal", |
||
| 140 | -+ | |||
| 355 | +! |
- labelstr = "",+ "vertical" |
||
| 141 | +356 |
- id = "USUBJID",+ ) |
||
| 142 | +357 |
- denom = c("N_col", "n"),
+ ) |
||
| 143 | +358 |
- drop = TRUE,+ } |
||
| 144 | +359 |
- .N_col, # nolint+ |
||
| 145 | +360 |
- .var = NULL,+ ############################################################# | |
||
| 146 | +361 |
- .df_row = NULL,+ # ---- Optionally, add table to the bottom of the plot. ---- |
||
| 147 | +362 |
- .stats = NULL,+ ############################################################# | |
||
| 148 | -+ | |||
| 363 | +3x |
- .formats = NULL,+ if (!is.null(table)) {
|
||
| 149 | -+ | |||
| 364 | +2x |
- .labels = NULL,+ df_stats_table <- df_grp %>% |
||
| 150 | -+ | |||
| 365 | +2x |
- .indent_mods = NULL,+ dplyr::summarise( |
||
| 151 | -+ | |||
| 366 | +2x |
- na_str = default_na_str()) {
+ h_format_row( |
||
| 152 | -46x | +367 | +2x |
- denom <- match.arg(denom)+ x = sfun(.data[[y]], ...)[table], |
| 153 | -46x | +368 | +2x |
- x_stats <- s_count_occurrences(+ format = table_format, |
| 154 | -46x | +369 | +2x |
- df = df, denom = denom, .N_col = .N_col, .df_row = .df_row, drop = drop, .var = .var, id = id+ labels = table_labels |
| 155 | +370 |
- )+ ), |
||
| 156 | -46x | +371 | +2x |
- if (is.null(unlist(x_stats))) {
+ .groups = "drop" |
| 157 | -3x | +|||
| 372 | +
- return(NULL)+ ) |
|||
| 158 | +373 |
- }+ |
||
| 159 | -43x | +374 | +2x |
- x_lvls <- names(x_stats[[1]])+ stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x))) |
| 160 | +375 | |||
| 161 | -+ | |||
| 376 | +2x |
- # Fill in with formatting defaults if needed+ df_stats_table <- df_stats_table %>% |
||
| 162 | -43x | +377 | +2x |
- .stats <- get_stats("count_occurrences", stats_in = .stats)
+ tidyr::pivot_longer( |
| 163 | -43x | +378 | +2x |
- .formats <- get_formats_from_stats(.stats, .formats)+ cols = -dplyr::all_of(c(group_var, x)), |
| 164 | -43x | +379 | +2x |
- .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls)+ names_to = "stat", |
| 165 | -43x | +380 | +2x |
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls)+ values_to = "value",+ |
+
| 381 | +2x | +
+ names_ptypes = list(stat = factor(levels = stats_lev)) |
||
| 166 | +382 | ++ |
+ )+ |
+ |
| 383 | ||||
| 167 | -42x | +384 | +2x |
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ tbl <- ggplot2::ggplot( |
| 168 | -43x | +385 | +2x |
- x_stats <- x_stats[.stats]+ df_stats_table, |
| 169 | -+ | |||
| 386 | +2x |
-
+ ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]]) |
||
| 170 | +387 |
- # Ungroup statistics with values for each level of x+ ) + |
||
| 171 | -43x | +388 | +2x |
- x_ungrp <- ungroup_stats(x_stats, .formats, list(), list())+ ggplot2::geom_text(size = table_font_size) + |
| 172 | -43x | +389 | +2x |
- x_stats <- x_ungrp[["x"]]+ ggplot2::theme_bw() + |
| 173 | -43x | +390 | +2x |
- .formats <- x_ungrp[[".formats"]]+ ggplot2::theme( |
| 174 | -+ | |||
| 391 | +2x |
-
+ panel.border = ggplot2::element_blank(), |
||
| 175 | -+ | |||
| 392 | +2x |
- # Auto format handling+ panel.grid.major = ggplot2::element_blank(), |
||
| 176 | -43x | +393 | +2x |
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ panel.grid.minor = ggplot2::element_blank(), |
| 177 | -+ | |||
| 394 | +2x |
-
+ axis.ticks = ggplot2::element_blank(), |
||
| 178 | -43x | +395 | +2x |
- in_rows(+ axis.title = ggplot2::element_blank(), |
| 179 | -43x | +396 | +2x |
- .list = x_stats,+ axis.text.x = ggplot2::element_blank(), |
| 180 | -43x | +397 | +2x |
- .formats = .formats,+ axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)), |
| 181 | -43x | +398 | +2x |
- .names = .labels,+ strip.text = ggplot2::element_text(hjust = 0), |
| 182 | -43x | +399 | +2x |
- .labels = .labels,+ strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")), |
| 183 | -43x | +400 | +2x |
- .indent_mods = .indent_mods,+ strip.background = ggplot2::element_rect(fill = "grey95", color = NA), |
| 184 | -43x | +401 | +2x |
- .format_na_strs = na_str+ legend.position = "none" |
| 185 | +402 |
- )+ ) |
||
| 186 | +403 |
- }+ |
||
| 187 | -+ | |||
| 404 | +2x |
-
+ if (!is.null(group_var)) {
|
||
| 188 | -+ | |||
| 405 | +2x |
- #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments+ tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1) |
||
| 189 | +406 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ } |
||
| 190 | +407 |
- #'+ |
||
| 191 | +408 |
- #' @return+ # align plot and table |
||
| 192 | -+ | |||
| 409 | +2x |
- #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions,+ cowplot::plot_grid(p, tbl, ncol = 1, align = "v", axis = "tblr") |
||
| 193 | +410 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ } else {
|
||
| 194 | -+ | |||
| 411 | +1x |
- #' the statistics from `s_count_occurrences()` to the table layout.+ p |
||
| 195 | +412 |
- #'+ } |
||
| 196 | +413 |
- #' @examples+ } |
||
| 197 | +414 |
- #' # Create table layout+ |
||
| 198 | +415 |
- #' lyt <- basic_table() %>%+ #' Helper function to get the right formatting in the optional table in `g_lineplot`. |
||
| 199 | +416 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 200 | +417 |
- #' add_colcounts() %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 201 | +418 |
- #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
+ #' |
||
| 202 | +419 |
- #'+ #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled. |
||
| 203 | +420 |
- #' # Apply table layout to data and produce `rtable` object+ #' Elements of `x` must be `numeric` vectors. |
||
| 204 | +421 |
- #' tbl <- lyt %>%+ #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must |
||
| 205 | +422 |
- #' build_table(df, alt_counts_df = df_adsl) %>%+ #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell` |
||
| 206 | +423 |
- #' prune_table()+ #' function through the `format` parameter. |
||
| 207 | +424 |
- #'+ #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must |
||
| 208 | +425 |
- #' tbl+ #' match the names of `x`. When a label is not specified for an element of `x`, |
||
| 209 | +426 |
- #'+ #' then this function tries to use `label` or `names` (in this order) attribute of that element |
||
| 210 | +427 |
- #' @export+ #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes |
||
| 211 | +428 |
- #' @order 2+ #' are attached to a given element of `x`, then the label is automatically generated. |
||
| 212 | +429 |
- count_occurrences <- function(lyt,+ #' |
||
| 213 | +430 |
- vars,+ #' @return A single row `data.frame` object. |
||
| 214 | +431 |
- id = "USUBJID",+ #' |
||
| 215 | +432 |
- drop = TRUE,+ #' @examples |
||
| 216 | +433 |
- var_labels = vars,+ #' mean_ci <- c(48, 51) |
||
| 217 | +434 |
- show_labels = "hidden",+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 218 | +435 |
- riskdiff = FALSE,+ #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)") |
||
| 219 | +436 |
- na_str = default_na_str(),+ #' labels <- c(mean = "My Mean") |
||
| 220 | +437 |
- nested = TRUE,+ #' h_format_row(x, format, labels) |
||
| 221 | +438 |
- ...,+ #' |
||
| 222 | +439 |
- table_names = vars,+ #' attr(mean_ci, "label") <- "Mean 95% CI" |
||
| 223 | +440 |
- .stats = "count_fraction_fixed_dp",+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 224 | +441 |
- .formats = NULL,+ #' h_format_row(x, format, labels) |
||
| 225 | +442 |
- .labels = NULL,+ #' |
||
| 226 | +443 |
- .indent_mods = NULL) {
+ #' @export |
||
| 227 | -7x | +|||
| 444 | +
- checkmate::assert_flag(riskdiff)+ h_format_row <- function(x, format, labels = NULL) {
|
|||
| 228 | +445 |
-
+ # cell: one row, one column data.frame |
||
| 229 | -7x | +446 | +37x |
- extra_args <- list(+ format_cell <- function(x, format, label = NULL) {
|
| 230 | -7x | +447 | +110x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ fc <- format_rcell(x = x, format = unlist(format)) |
| 231 | -+ | |||
| 448 | +110x |
- )+ if (is.na(fc)) {
|
||
| 232 | -7x | +|||
| 449 | +! |
- s_args <- list(id = id, drop = drop, ...)+ fc <- "NA" |
||
| 233 | +450 |
-
+ } |
||
| 234 | -7x | +451 | +110x |
- if (isFALSE(riskdiff)) {
+ x_label <- attr(x, "label") |
| 235 | -6x | -
- extra_args <- c(extra_args, s_args)- |
- ||
| 236 | -+ | 452 | +110x |
- } else {
+ if (!is.null(label) && !is.na(label)) {
|
| 237 | -1x | +453 | +109x |
- extra_args <- c(+ names(fc) <- label |
| 238 | +454 | 1x |
- extra_args,+ } else if (!is.null(x_label) && !is.na(x_label)) {
|
|
| 239 | -1x | +|||
| 455 | +! |
- list(+ names(fc) <- x_label |
||
| 240 | +456 | 1x |
- afun = list("s_count_occurrences" = a_count_occurrences),
+ } else if (length(x) == length(fc)) {
|
|
| 241 | -1x | +|||
| 457 | +! |
- s_args = s_args+ names(fc) <- names(x) |
||
| 242 | +458 |
- )+ } |
||
| 243 | -+ | |||
| 459 | +110x |
- )+ as.data.frame(t(fc)) |
||
| 244 | +460 |
} |
||
| 245 | +461 | |||
| 246 | -7x | -
- analyze(- |
- ||
| 247 | -7x | -
- lyt = lyt,- |
- ||
| 248 | -7x | -
- vars = vars,- |
- ||
| 249 | -7x | -
- afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),- |
- ||
| 250 | -7x | -
- var_labels = var_labels,- |
- ||
| 251 | -7x | -
- show_labels = show_labels,- |
- ||
| 252 | -7x | +462 | +37x |
- table_names = table_names,+ row <- do.call( |
| 253 | -7x | +463 | +37x |
- na_str = na_str,+ cbind, |
| 254 | -7x | +464 | +37x |
- nested = nested,+ lapply( |
| 255 | -7x | +465 | +37x |
- extra_args = extra_args+ names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn]) |
| 256 | +466 |
- )+ ) |
||
| 257 | +467 |
- }+ ) |
||
| 258 | +468 | |||
| 259 | -- |
- #' @describeIn count_occurrences Layout-creating function which can take content function arguments- |
- ||
| 260 | -- |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].- |
- ||
| 261 | -- |
- #'- |
- ||
| 262 | -+ | |||
| 469 | +37x |
- #' @return+ row |
||
| 263 | +470 |
- #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions,+ } |
||
| 264 | +471 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ |
||
| 265 | +472 |
- #' containing the statistics from `s_count_occurrences()` to the table layout.+ #' Control Function for `g_lineplot` Function |
||
| 266 | +473 |
#' |
||
| 267 | +474 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 268 | +475 |
- #' # Layout creating function with custom format.+ #' |
||
| 269 | +476 |
- #' basic_table() %>%+ #' Default values for `variables` parameter in `g_lineplot` function. |
||
| 270 | +477 |
- #' add_colcounts() %>%+ #' A variable's default value can be overwritten for any variable. |
||
| 271 | +478 |
- #' split_rows_by("SEX", child_labels = "visible") %>%
+ #' |
||
| 272 | +479 |
- #' summarize_occurrences(+ #' @param x (`character`)\cr x variable name. |
||
| 273 | +480 |
- #' var = "MHDECOD",+ #' @param y (`character`)\cr y variable name. |
||
| 274 | +481 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ #' @param group_var (`character` or `NA`)\cr group variable name. |
||
| 275 | +482 |
- #' ) %>%+ #' @param strata (`character` or `NA`)\cr deprecated - group variable name. |
||
| 276 | +483 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' @param subject_var (`character` or `NA`)\cr subject variable name. |
||
| 277 | +484 |
- #'+ #' @param cohort_id (`character` or `NA`)\cr deprecated - subject variable name. |
||
| 278 | +485 |
- #' @export+ #' @param paramcd (`character` or `NA`)\cr `paramcd` variable name. |
||
| 279 | +486 |
- #' @order 3+ #' @param y_unit (`character` or `NA`)\cr `y_unit` variable name. |
||
| 280 | +487 |
- summarize_occurrences <- function(lyt,+ #' |
||
| 281 | +488 |
- var,+ #' @return A named character vector of variable names. |
||
| 282 | +489 |
- id = "USUBJID",+ #' |
||
| 283 | +490 |
- drop = TRUE,+ #' @examples |
||
| 284 | +491 |
- riskdiff = FALSE,+ #' control_lineplot_vars() |
||
| 285 | +492 |
- na_str = default_na_str(),+ #' control_lineplot_vars(group_var = NA) |
||
| 286 | +493 |
- ...,+ #' |
||
| 287 | +494 |
- .stats = "count_fraction_fixed_dp",+ #' @export |
||
| 288 | +495 |
- .formats = NULL,+ control_lineplot_vars <- function(x = "AVISIT", y = "AVAL", group_var = "ARM", paramcd = "PARAMCD", y_unit = "AVALU", |
||
| 289 | +496 |
- .indent_mods = NULL,+ subject_var = "USUBJID", strata = lifecycle::deprecated(), |
||
| 290 | +497 |
- .labels = NULL) {
+ cohort_id = lifecycle::deprecated()) {
|
||
| 291 | -2x | -
- checkmate::assert_flag(riskdiff)- |
- ||
| 292 | -+ | 498 | +3x |
-
+ if (lifecycle::is_present(strata)) {
|
| 293 | -2x | +|||
| 499 | +! |
- extra_args <- list(+ lifecycle::deprecate_warn("0.9.2", "control_lineplot_vars(strata)", "control_lineplot_vars(group_var)")
|
||
| 294 | -2x | +|||
| 500 | +! |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ group_var <- strata |
||
| 295 | +501 |
- )- |
- ||
| 296 | -2x | -
- s_args <- list(id = id, drop = drop, ...)+ } |
||
| 297 | +502 | |||
| 298 | -2x | -
- if (isFALSE(riskdiff)) {
- |
- ||
| 299 | -1x | -
- extra_args <- c(extra_args, s_args)- |
- ||
| 300 | -- |
- } else {
- |
- ||
| 301 | -1x | -
- extra_args <- c(- |
- ||
| 302 | -1x | -
- extra_args,- |
- ||
| 303 | -1x | -
- list(- |
- ||
| 304 | -1x | -
- afun = list("s_count_occurrences" = a_count_occurrences),
- |
- ||
| 305 | -1x | +503 | +3x |
- s_args = s_args+ if (lifecycle::is_present(cohort_id)) {
|
| 306 | -+ | |||
| 504 | +! |
- )+ lifecycle::deprecate_warn("0.9.2", "control_lineplot_vars(cohort_id)", "control_lineplot_vars(subject_id)")
|
||
| 307 | -+ | |||
| 505 | +! |
- )+ subject_id <- cohort_id |
||
| 308 | +506 |
} |
||
| 309 | +507 | |||
| 310 | -2x | +508 | +3x |
- summarize_row_groups(+ checkmate::assert_string(x) |
| 311 | -2x | +509 | +3x |
- lyt = lyt,+ checkmate::assert_string(y) |
| 312 | -2x | +510 | +3x |
- var = var,+ checkmate::assert_string(group_var, na.ok = TRUE) |
| 313 | -2x | +511 | +3x |
- cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ checkmate::assert_string(subject_var, na.ok = TRUE) |
| 314 | -2x | +512 | +3x |
- na_str = na_str,+ checkmate::assert_string(paramcd, na.ok = TRUE) |
| 315 | -2x | +513 | +3x |
- extra_args = extra_args+ checkmate::assert_string(y_unit, na.ok = TRUE) |
| 316 | +514 |
- )+ + |
+ ||
| 515 | +3x | +
+ variables <- c(x = x, y = y, group_var = group_var, paramcd = paramcd, y_unit = y_unit, subject_var = subject_var)+ |
+ ||
| 516 | +3x | +
+ return(variables) |
||
| 317 | +517 |
}@@ -93471,14 +95004,14 @@ tern coverage - 90.46% |
| 1 |
- #' Summary numeric variables in columns+ #' Encode Categorical Missing Values in a Data Frame |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Layout-creating function which can be used for creating column-wise summary tables.+ #' This is a helper function to encode missing entries across groups of categorical |
||
| 6 |
- #' This function sets the analysis methods as column labels and is a wrapper for+ #' variables in a data frame. |
||
| 7 |
- #' [rtables::analyze_colvars()]. It was designed principally for PK tables.+ #' |
||
| 8 |
- #'+ #' @details Missing entries are those with `NA` or empty strings and will |
||
| 9 |
- #' @inheritParams argument_convention+ #' be replaced with a specified value. If factor variables include missing |
||
| 10 |
- #' @inheritParams rtables::analyze_colvars+ #' values, the missing value will be inserted as the last level. |
||
| 11 |
- #' @param imp_rule (`character`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can+ #' Similarly, in case character or logical variables should be converted to factors |
||
| 12 |
- #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order+ #' with the `char_as_factor` or `logical_as_factor` options, the missing values will |
||
| 13 |
- #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()]+ #' be set as the last level. |
||
| 14 |
- #' for more details on imputation.+ #' |
||
| 15 |
- #' @param avalcat_var (`character`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a+ #' @param data (`data.frame`)\cr data set. |
||
| 16 |
- #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of+ #' @param omit_columns (`character`)\cr names of variables from `data` that should |
||
| 17 |
- #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable+ #' not be modified by this function. |
||
| 18 |
- #' used to calculate the `n_blq` statistic (if included in `.stats`).+ #' @param char_as_factor (`flag`)\cr whether to convert character variables |
||
| 19 |
- #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will+ #' in `data` to factors. |
||
| 20 |
- #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is+ #' @param logical_as_factor (`flag`)\cr whether to convert logical variables |
||
| 21 |
- #' used for multiple tables with different data. Defaults to `FALSE`.+ #' in `data` to factors. |
||
| 22 |
- #' @param row_labels (`character`)\cr as this function works in columns space, usual `.labels`+ #' @param na_level (`string`)\cr used to replace all `NA` or empty |
||
| 23 |
- #' character vector applies on the column space. You can change the row labels by defining this+ #' values inside non-`omit_columns` columns. |
||
| 24 |
- #' parameter to a named character vector with names corresponding to the split values. It defaults+ #' |
||
| 25 |
- #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label.+ #' @return A `data.frame` with the chosen modifications applied. |
||
| 26 |
- #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current+ #' |
||
| 27 |
- #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr`+ #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions. |
||
| 28 |
- #' to define row labels. This behavior is not supported as we never need to overload row labels.+ #' |
||
| 29 |
- #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns.+ #' @examples |
||
| 30 |
- #' This option allows you to add multiple instances of this functions, also in a nested fashion,+ #' my_data <- data.frame( |
||
| 31 |
- #' without adding more splits. This split must happen only one time on a single layout.+ #' u = c(TRUE, FALSE, NA, TRUE), |
||
| 32 |
- #'+ #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
|
||
| 33 |
- #' @return+ #' w = c("A", "B", NA, "C"),
|
||
| 34 |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' x = c("D", "E", "F", NA),
|
||
| 35 |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ #' y = c("G", "H", "I", ""),
|
||
| 36 |
- #' in columns, and add it to the table layout.+ #' z = c(1, 2, 3, 4), |
||
| 37 |
- #'+ #' stringsAsFactors = FALSE |
||
| 38 |
- #' @note This is an experimental implementation of [rtables::summarize_row_groups()] and+ #' ) |
||
| 39 |
- #' [rtables::analyze_colvars()] that may be subjected to changes as `rtables` extends its+ #' |
||
| 40 |
- #' support to more complex analysis pipelines on the column space. For the same reasons,+ #' # Example 1 |
||
| 41 |
- #' we encourage to read the examples carefully and file issues for cases that differ from+ #' # Encode missing values in all character or factor columns. |
||
| 42 |
- #' them.+ #' df_explicit_na(my_data) |
||
| 43 |
- #'+ #' # Also convert logical columns to factor columns. |
||
| 44 |
- #' Here `labelstr` behaves differently than usual. If it is not defined (default as `NULL`),+ #' df_explicit_na(my_data, logical_as_factor = TRUE) |
||
| 45 |
- #' row labels are assigned automatically to the split values in case of `rtables::analyze_colvars`+ #' # Encode missing values in a subset of columns. |
||
| 46 |
- #' (`do_summarize_row_groups = FALSE`, the default), and to the group label for+ #' df_explicit_na(my_data, omit_columns = c("x", "y"))
|
||
| 47 |
- #' `do_summarize_row_groups = TRUE`.+ #' |
||
| 48 |
- #'+ #' # Example 2 |
||
| 49 |
- #' @seealso [analyze_vars()], [rtables::analyze_colvars()].+ #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable. |
||
| 50 |
- #'+ #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not |
||
| 51 |
- #' @examples+ #' # included when generating `rtables`. |
||
| 52 |
- #' library(dplyr)+ #' adsl <- tern_ex_adsl |
||
| 53 |
- #'+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 54 |
- #' # Data preparation+ #' adsl <- df_explicit_na(adsl) |
||
| 55 |
- #' adpp <- tern_ex_adpp %>% h_pkparam_sort()+ #' |
||
| 56 |
- #'+ #' # If you want the `Na` values to be displayed in the table use the `na_level` argument. |
||
| 57 |
- #' lyt <- basic_table() %>%+ #' adsl <- tern_ex_adsl |
||
| 58 |
- #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>%+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 59 |
- #' split_rows_by(+ #' adsl <- df_explicit_na(adsl, na_level = "Missing Values") |
||
| 60 |
- #' var = "SEX",+ #' |
||
| 61 |
- #' label_pos = "topleft",+ #' # Example 3 |
||
| 62 |
- #' child_label = "hidden"+ #' # Numeric variables that have missing values are not altered. This means that any `NA` value in |
||
| 63 |
- #' ) %>% # Removes duplicated labels+ #' # a numeric variable will not be included in the summary statistics, nor will they be included |
||
| 64 |
- #' analyze_vars_in_cols(vars = "AGE")+ #' # in the denominator value for calculating the percent values. |
||
| 65 |
- #' result <- build_table(lyt = lyt, df = adpp)+ #' adsl <- tern_ex_adsl |
||
| 66 |
- #' result+ #' adsl$AGE[adsl$AGE < 30] <- NA |
||
| 67 |
- #'+ #' adsl <- df_explicit_na(adsl) |
||
| 68 |
- #' # By selecting just some statistics and ad-hoc labels+ #' |
||
| 69 |
- #' lyt <- basic_table() %>%+ #' @export |
||
| 70 |
- #' split_rows_by(var = "ARM", label_pos = "topleft") %>%+ df_explicit_na <- function(data, |
||
| 71 |
- #' split_rows_by(+ omit_columns = NULL, |
||
| 72 |
- #' var = "SEX",+ char_as_factor = TRUE, |
||
| 73 |
- #' label_pos = "topleft",+ logical_as_factor = FALSE, |
||
| 74 |
- #' child_labels = "hidden",+ na_level = "<Missing>") {
|
||
| 75 | -+ | 21x |
- #' split_fun = drop_split_levels+ checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) |
| 76 | -+ | 20x |
- #' ) %>%+ checkmate::assert_data_frame(data) |
| 77 | -+ | 19x |
- #' analyze_vars_in_cols(+ checkmate::assert_flag(char_as_factor) |
| 78 | -+ | 18x |
- #' vars = "AGE",+ checkmate::assert_flag(logical_as_factor) |
| 79 | -+ | 18x |
- #' .stats = c("n", "cv", "geom_mean"),
+ checkmate::assert_string(na_level) |
| 80 |
- #' .labels = c(+ |
||
| 81 | -+ | 16x |
- #' n = "aN",+ target_vars <- if (is.null(omit_columns)) {
|
| 82 | -+ | 14x |
- #' cv = "aCV",+ names(data) |
| 83 |
- #' geom_mean = "aGeomMean"+ } else {
|
||
| 84 | -+ | 2x |
- #' )+ setdiff(names(data), omit_columns) # May have duplicates. |
| 85 |
- #' )+ } |
||
| 86 | -+ | 16x |
- #' result <- build_table(lyt = lyt, df = adpp)+ if (length(target_vars) == 0) {
|
| 87 | -+ | 1x |
- #' result+ return(data) |
| 88 |
- #'+ } |
||
| 89 |
- #' # Changing row labels+ |
||
| 90 | -+ | 15x |
- #' lyt <- basic_table() %>%+ l_target_vars <- split(target_vars, target_vars) |
| 91 |
- #' analyze_vars_in_cols(+ |
||
| 92 |
- #' vars = "AGE",+ # Makes sure target_vars exist in data and names are not duplicated. |
||
| 93 | -+ | 15x |
- #' row_labels = "some custom label"+ assert_df_with_variables(data, l_target_vars) |
| 94 |
- #' )+ |
||
| 95 | -+ | 15x |
- #' result <- build_table(lyt, df = adpp)+ for (x in target_vars) {
|
| 96 | -+ | 276x |
- #' result+ xi <- data[[x]] |
| 97 | -+ | 276x |
- #'+ xi_label <- obj_label(xi) |
| 98 |
- #' # Pharmacokinetic parameters+ |
||
| 99 |
- #' lyt <- basic_table() %>%+ # Determine whether to convert character or logical input. |
||
| 100 | -+ | 276x |
- #' split_rows_by(+ do_char_conversion <- is.character(xi) && char_as_factor |
| 101 | -+ | 276x |
- #' var = "TLG_DISPLAY",+ do_logical_conversion <- is.logical(xi) && logical_as_factor |
| 102 |
- #' split_label = "PK Parameter",+ |
||
| 103 |
- #' label_pos = "topleft",+ # Pre-convert logical to character to deal correctly with replacing NA |
||
| 104 |
- #' child_label = "hidden"+ # values below. |
||
| 105 | -+ | 276x |
- #' ) %>%+ if (do_logical_conversion) {
|
| 106 | -+ | 2x |
- #' analyze_vars_in_cols(+ xi <- as.character(xi) |
| 107 |
- #' vars = "AVAL"+ } |
||
| 108 |
- #' )+ |
||
| 109 | -+ | 276x |
- #' result <- build_table(lyt, df = adpp)+ if (is.factor(xi) || is.character(xi)) {
|
| 110 |
- #' result+ # Handle empty strings and NA values. |
||
| 111 | -+ | 198x |
- #'+ xi <- explicit_na(sas_na(xi), label = na_level) |
| 112 |
- #' # Multiple calls (summarize label and analyze underneath)+ |
||
| 113 |
- #' lyt <- basic_table() %>%+ # Convert to factors if requested for the original type, |
||
| 114 |
- #' split_rows_by(+ # set na_level as the last value. |
||
| 115 | -+ | 198x |
- #' var = "TLG_DISPLAY",+ if (do_char_conversion || do_logical_conversion) {
|
| 116 | -+ | 71x |
- #' split_label = "PK Parameter",+ levels_xi <- setdiff(sort(unique(xi)), na_level) |
| 117 | -+ | 71x |
- #' label_pos = "topleft"+ if (na_level %in% unique(xi)) {
|
| 118 | -+ | 18x |
- #' ) %>%+ levels_xi <- c(levels_xi, na_level) |
| 119 |
- #' analyze_vars_in_cols(+ } |
||
| 120 |
- #' vars = "AVAL",+ |
||
| 121 | -+ | 71x |
- #' do_summarize_row_groups = TRUE # does a summarize level+ xi <- factor(xi, levels = levels_xi) |
| 122 |
- #' ) %>%+ } |
||
| 123 |
- #' split_rows_by("SEX",
+
|
||
| 124 | -+ | 198x |
- #' child_label = "hidden",+ data[, x] <- formatters::with_label(xi, label = xi_label) |
| 125 |
- #' label_pos = "topleft"+ } |
||
| 126 |
- #' ) %>%+ } |
||
| 127 | -+ | 15x |
- #' analyze_vars_in_cols(+ return(data) |
| 128 |
- #' vars = "AVAL",+ } |
| 129 | +1 |
- #' split_col_vars = FALSE # avoids re-splitting the columns+ #' Count Patients with Marked Laboratory Abnormalities |
||
| 130 | +2 |
- #' )+ #' |
||
| 131 | +3 |
- #' result <- build_table(lyt, df = adpp)+ #' @description `r lifecycle::badge("stable")`
|
||
| 132 | +4 |
- #' result+ #' |
||
| 133 | +5 |
- #'+ #' Primary analysis variable `.var` indicates whether single, replicated or last marked laboratory |
||
| 134 | +6 |
- #' @export+ #' abnormality was observed (`factor`). Additional analysis variables are `id` (`character` or `factor`) |
||
| 135 | +7 |
- analyze_vars_in_cols <- function(lyt,+ #' and `direction` (`factor`) indicating the direction of the abnormality. Denominator is number of |
||
| 136 | +8 |
- vars,+ #' patients with at least one valid measurement during the analysis. |
||
| 137 | +9 |
- ...,+ #' * For `Single, not last` and `Last or replicated`: Numerator is number of patients |
||
| 138 | +10 |
- .stats = c(+ #' with `Single, not last` and `Last or replicated` levels, respectively. |
||
| 139 | +11 |
- "n",+ #' * For `Any`: Numerator is the number of patients with either single or |
||
| 140 | +12 |
- "mean",+ #' replicated marked abnormalities. |
||
| 141 | +13 |
- "sd",+ #' |
||
| 142 | +14 |
- "se",+ #' @inheritParams argument_convention |
||
| 143 | +15 |
- "cv",+ #' @param category (`list`)\cr with different marked category names for single |
||
| 144 | +16 |
- "geom_cv"+ #' and last or replicated. |
||
| 145 | +17 |
- ),+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_marked")`
|
||
| 146 | +18 |
- .labels = c(+ #' to see available statistics for this function. |
||
| 147 | +19 |
- n = "n",+ #' |
||
| 148 | +20 |
- mean = "Mean",+ #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has |
||
| 149 | +21 |
- sd = "SD",+ #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the |
||
| 150 | +22 |
- se = "SE",+ #' patient will be counted only under the `Last or replicated` category. |
||
| 151 | +23 |
- cv = "CV (%)",+ #' |
||
| 152 | +24 |
- geom_cv = "CV % Geometric Mean"+ #' @name abnormal_by_marked |
||
| 153 | +25 |
- ),+ #' @order 1 |
||
| 154 | +26 |
- row_labels = NULL,+ NULL |
||
| 155 | +27 |
- do_summarize_row_groups = FALSE,+ |
||
| 156 | +28 |
- split_col_vars = TRUE,+ #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities. |
||
| 157 | +29 |
- imp_rule = NULL,+ #' |
||
| 158 | +30 |
- avalcat_var = "AVALCAT1",+ #' @return |
||
| 159 | +31 |
- cache = FALSE,+ #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`, |
||
| 160 | +32 |
- .indent_mods = NULL,+ #' `Last or replicated`, and `Any` results. |
||
| 161 | +33 |
- na_level = lifecycle::deprecated(),+ #' |
||
| 162 | +34 |
- na_str = default_na_str(),+ #' @keywords internal |
||
| 163 | +35 |
- nested = TRUE,+ s_count_abnormal_by_marked <- function(df, |
||
| 164 | +36 |
- .formats = NULL,+ .var = "AVALCAT1", |
||
| 165 | +37 |
- .aligns = NULL) {
- |
- ||
| 166 | -10x | -
- extra_args <- list(...)- |
- ||
| 167 | -10x | -
- if (lifecycle::is_present(na_level)) {
- |
- ||
| 168 | -! | -
- lifecycle::deprecate_warn("0.9.1", "analyze_vars_in_cols(na_level)", "analyze_vars_in_cols(na_str)")
- |
- ||
| 169 | -! | -
- na_str <- na_level+ .spl_context, |
||
| 170 | +38 |
- }+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
||
| 171 | +39 |
-
+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
|
||
| 172 | -10x | +40 | +3x |
- checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE)+ checkmate::assert_string(.var) |
| 173 | -10x | +41 | +3x |
- checkmate::assert_character(row_labels, null.ok = TRUE)+ checkmate::assert_list(variables) |
| 174 | -10x | +42 | +3x |
- checkmate::assert_int(.indent_mods, null.ok = TRUE)+ checkmate::assert_list(category) |
| 175 | -10x | +43 | +3x |
- checkmate::assert_flag(nested)+ checkmate::assert_subset(names(category), c("single", "last_replicated"))
|
| 176 | -10x | +44 | +3x |
- checkmate::assert_flag(split_col_vars)+ checkmate::assert_subset(names(variables), c("id", "param", "direction"))
|
| 177 | -10x | +45 | +3x |
- checkmate::assert_flag(do_summarize_row_groups)+ checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1) |
| 178 | +46 | |||
| 179 | -- |
- # Filtering- |
- ||
| 180 | -10x | -
- met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
- |
- ||
| 181 | -10x | +47 | +2x |
- .stats <- get_stats(met_grps, stats_in = .stats)+ assert_df_with_variables(df, c(aval = .var, variables)) |
| 182 | -10x | +48 | +2x |
- formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 183 | -10x | -
- labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels)- |
- ||
| 184 | -! | +49 | +2x |
- if ("control" %in% names(extra_args)) labels_v <- labels_v %>% labels_use_control(extra_args[["control"]], .labels)
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 185 | +50 | |||
| 186 | -- |
- # Check for vars in the case that one or more are used- |
- ||
| 187 | -10x | -
- if (length(vars) == 1) {
- |
- ||
| 188 | -7x | -
- vars <- rep(vars, length(.stats))- |
- ||
| 189 | -3x | -
- } else if (length(vars) != length(.stats)) {
- |
- ||
| 190 | -1x | -
- stop(- |
- ||
| 191 | -1x | -
- "Analyzed variables (vars) does not have the same ",- |
- ||
| 192 | -1x | -
- "number of elements of specified statistics (.stats)."- |
- ||
| 193 | -- |
- )- |
- ||
| 194 | -- |
- }- |
- ||
| 195 | +51 | |||
| 196 | -9x | -
- if (split_col_vars) {
- |
- ||
| 197 | -- |
- # Checking there is not a previous identical column split- |
- ||
| 198 | -8x | +52 | +2x |
- clyt <- tail(clayout(lyt), 1)[[1]]+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
| 199 | +53 | - - | -||
| 200 | -8x | -
- dummy_lyt <- split_cols_by_multivar(- |
- ||
| 201 | -8x | -
- lyt = basic_table(),+ # Patients in the denominator have at least one post-baseline visit. |
||
| 202 | -8x | +54 | +2x |
- vars = vars,+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
| 203 | -8x | +55 | +2x |
- varlabels = labels_v+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
| 204 | +56 |
- )+ # Some subjects may have a record for high and low directions but |
||
| 205 | +57 |
-
+ # should be counted only once. |
||
| 206 | -8x | -
- if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
- |
- ||
| 207 | -! | -
- stop(- |
- ||
| 208 | -! | -
- "Column split called again with the same values. ",- |
- ||
| 209 | -! | -
- "This can create many unwanted columns. Please consider adding ",- |
- ||
| 210 | -! | -
- "split_col_vars = FALSE to the last call of ",- |
- ||
| 211 | -! | -
- deparse(sys.calls()[[sys.nframe() - 1]]), "."- |
- ||
| 212 | -- |
- )- |
- ||
| 213 | -+ | 58 | +2x |
- }+ denom <- length(unique(subj_cur_col)) |
| 214 | +59 | |||
| 215 | -- |
- # Main col split- |
- ||
| 216 | -8x | -
- lyt <- split_cols_by_multivar(- |
- ||
| 217 | -8x | +60 | +2x |
- lyt = lyt,+ if (denom != 0) {
|
| 218 | -8x | +61 | +2x |
- vars = vars,+ subjects_last_replicated <- unique( |
| 219 | -8x | +62 | +2x |
- varlabels = labels_v+ df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE] |
| 220 | +63 |
) |
||
| 221 | -- |
- }- |
- ||
| 222 | -- | - - | -||
| 223 | -9x | -
- env <- new.env() # create caching environment- |
- ||
| 224 | -- | - - | -||
| 225 | -9x | +64 | +2x |
- if (do_summarize_row_groups) {
+ subjects_single <- unique( |
| 226 | +65 | 2x |
- if (length(unique(vars)) > 1) {
- |
- |
| 227 | -! | -
- stop("When using do_summarize_row_groups only one label level var should be inserted.")
- |
- ||
| 228 | -- |
- }+ df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE] |
||
| 229 | +66 |
-
+ ) |
||
| 230 | +67 |
- # Function list for do_summarize_row_groups. Slightly different handling of labels+ # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group. |
||
| 231 | +68 | 2x |
- cfun_list <- Map(+ subjects_single <- setdiff(subjects_single, subjects_last_replicated) |
|
| 232 | +69 | 2x |
- function(stat, use_cache, cache_env) {
+ n_single <- length(subjects_single) |
|
| 233 | -12x | +70 | +2x |
- function(u, .spl_context, labelstr, .df_row, ...) {
+ n_last_replicated <- length(subjects_last_replicated) |
| 234 | -+ | |||
| 71 | +2x |
- # Statistic+ n_any <- n_single + n_last_replicated |
||
| 235 | -24x | +72 | +2x |
- var_row_val <- paste(+ result <- list(count_fraction = list( |
| 236 | -24x | +73 | +2x |
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ "Single, not last" = c(n_single, n_single / denom), |
| 237 | -24x | +|||
| 74 | +2x |
- paste(.spl_context$value, collapse = "_"),+ "Last or replicated" = c(n_last_replicated, n_last_replicated / denom), |
||
| 238 | -24x | +75 | +2x |
- sep = "_"+ "Any Abnormality" = c(n_any, n_any / denom) |
| 239 | +76 |
- )+ )) |
||
| 240 | -24x | +|||
| 77 | +
- if (use_cache) {
+ } else {
|
|||
| 241 | +78 | ! |
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ result <- list(count_fraction = list( |
|
| 242 | +79 | ! |
- x_stats <- cache_env[[var_row_val]]+ "Single, not last" = c(0, 0), |
|
| 243 | -+ | |||
| 80 | +! |
- } else {
+ "Last or replicated" = c(0, 0), |
||
| 244 | -24x | +|||
| 81 | +! |
- x_stats <- s_summary(u, ...)+ "Any Abnormality" = c(0, 0) |
||
| 245 | +82 |
- }+ )) |
||
| 246 | +83 |
-
+ } |
||
| 247 | -24x | +|||
| 84 | +
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+
|
|||
| 248 | -24x | +85 | +2x |
- res <- x_stats[[stat]]+ result |
| 249 | +86 |
- } else {
+ } |
||
| 250 | -! | +|||
| 87 | +
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+
|
|||
| 251 | -! | +|||
| 88 | +
- res_imp <- imputation_rule(+ #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun` |
|||
| 252 | -! | +|||
| 89 | +
- .df_row, x_stats, stat,+ #' in `count_abnormal_by_marked()`. |
|||
| 253 | -! | +|||
| 90 | +
- imp_rule = imp_rule,+ #' |
|||
| 254 | -! | +|||
| 91 | +
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ #' @return |
|||
| 255 | -! | +|||
| 92 | +
- avalcat_var = avalcat_var+ #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 256 | +93 |
- )+ #' |
||
| 257 | -! | +|||
| 94 | +
- res <- res_imp[["val"]]+ #' @keywords internal |
|||
| 258 | -! | +|||
| 95 | +
- na_str <- res_imp[["na_str"]]+ a_count_abnormal_by_marked <- make_afun( |
|||
| 259 | +96 |
- }+ s_count_abnormal_by_marked, |
||
| 260 | +97 |
-
+ .formats = c(count_fraction = format_count_fraction) |
||
| 261 | +98 |
- # Label check and replacement+ ) |
||
| 262 | -24x | +|||
| 99 | +
- if (length(row_labels) > 1) {
+
|
|||
| 263 | -12x | +|||
| 100 | +
- if (!(labelstr %in% names(row_labels))) {
+ #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments |
|||
| 264 | -! | +|||
| 101 | +
- stop(+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 265 | -! | +|||
| 102 | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ #' |
|||
| 266 | -! | +|||
| 103 | +
- "that contains the split values. In the current split variable ",+ #' @return |
|||
| 267 | -! | +|||
| 104 | +
- .spl_context$split[nrow(.spl_context)],+ #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions, |
|||
| 268 | -! | +|||
| 105 | +
- " the labelstr value (split value by default) ", labelstr, " is not in",+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 269 | -! | +|||
| 106 | +
- " row_labels names: ", names(row_labels)+ #' the statistics from `s_count_abnormal_by_marked()` to the table layout. |
|||
| 270 | +107 |
- )+ #' |
||
| 271 | +108 |
- }+ #' @examples |
||
| 272 | -12x | +|||
| 109 | +
- lbl <- unlist(row_labels[labelstr])+ #' library(dplyr) |
|||
| 273 | +110 |
- } else {
+ #' |
||
| 274 | -12x | +|||
| 111 | +
- lbl <- labelstr+ #' df <- data.frame( |
|||
| 275 | +112 |
- }+ #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))), |
||
| 276 | +113 |
-
+ #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
|
||
| 277 | +114 |
- # Cell creation+ #' ANRIND = factor(c( |
||
| 278 | -24x | +|||
| 115 | +
- rcell(res,+ #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH", |
|||
| 279 | -24x | +|||
| 116 | +
- label = lbl,+ #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW", |
|||
| 280 | -24x | +|||
| 117 | +
- format = formats_v[names(formats_v) == stat][[1]],+ #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW" |
|||
| 281 | -24x | +|||
| 118 | +
- format_na_str = na_str,+ #' )), |
|||
| 282 | -24x | +|||
| 119 | +
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
|
|||
| 283 | -24x | +|||
| 120 | +
- align = .aligns+ #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
|
|||
| 284 | +121 |
- )+ #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
|
||
| 285 | +122 |
- }+ #' stringsAsFactors = FALSE |
||
| 286 | +123 |
- },+ #' ) |
||
| 287 | -2x | +|||
| 124 | +
- stat = .stats,+ #' |
|||
| 288 | -2x | +|||
| 125 | +
- use_cache = cache,+ #' df <- df %>% |
|||
| 289 | -2x | +|||
| 126 | +
- cache_env = replicate(length(.stats), env)+ #' mutate(abn_dir = factor( |
|||
| 290 | +127 |
- )+ #' case_when( |
||
| 291 | +128 |
-
+ #' ANRIND == "LOW LOW" ~ "Low", |
||
| 292 | +129 |
- # Main call to rtables+ #' ANRIND == "HIGH HIGH" ~ "High", |
||
| 293 | -2x | +|||
| 130 | +
- summarize_row_groups(+ #' TRUE ~ "" |
|||
| 294 | -2x | +|||
| 131 | +
- lyt = lyt,+ #' ), |
|||
| 295 | -2x | +|||
| 132 | +
- var = unique(vars),+ #' levels = c("Low", "High")
|
|||
| 296 | -2x | +|||
| 133 | +
- cfun = cfun_list,+ #' )) |
|||
| 297 | -2x | +|||
| 134 | +
- na_str = na_str,+ #' |
|||
| 298 | -2x | +|||
| 135 | +
- extra_args = extra_args+ #' # Select only post-baseline records. |
|||
| 299 | +136 |
- )+ #' df <- df %>% filter(ONTRTFL == "Y") |
||
| 300 | +137 |
- } else {
+ #' df_crp <- df %>% |
||
| 301 | +138 |
- # Function list for analyze_colvars+ #' filter(PARAMCD == "CRP") %>% |
||
| 302 | -7x | +|||
| 139 | +
- afun_list <- Map(+ #' droplevels() |
|||
| 303 | -7x | +|||
| 140 | +
- function(stat, use_cache, cache_env) {
+ #' full_parent_df <- list(df_crp, "not_needed") |
|||
| 304 | -32x | +|||
| 141 | +
- function(u, .spl_context, .df_row, ...) {
+ #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed") |
|||
| 305 | +142 |
- # Main statistics+ #' spl_context <- data.frame( |
||
| 306 | -210x | +|||
| 143 | +
- var_row_val <- paste(+ #' split = c("PARAMCD", "GRADE_DIR"),
|
|||
| 307 | -210x | +|||
| 144 | +
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ #' full_parent_df = I(full_parent_df), |
|||
| 308 | -210x | +|||
| 145 | +
- paste(.spl_context$value, collapse = "_"),+ #' cur_col_subset = I(cur_col_subset) |
|||
| 309 | -210x | +|||
| 146 | +
- sep = "_"+ #' ) |
|||
| 310 | +147 |
- )+ #' |
||
| 311 | -210x | +|||
| 148 | +
- if (use_cache) {
+ #' map <- unique( |
|||
| 312 | -16x | +|||
| 149 | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
|
|||
| 313 | -56x | +|||
| 150 | +
- x_stats <- cache_env[[var_row_val]]+ #' ) %>% |
|||
| 314 | +151 |
- } else {
+ #' lapply(as.character) %>% |
||
| 315 | -154x | +|||
| 152 | +
- x_stats <- s_summary(u, ...)+ #' as.data.frame() %>% |
|||
| 316 | +153 |
- }+ #' arrange(PARAMCD, abn_dir) |
||
| 317 | +154 |
-
+ #' |
||
| 318 | -210x | +|||
| 155 | +
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ #' basic_table() %>% |
|||
| 319 | -170x | +|||
| 156 | +
- res <- x_stats[[stat]]+ #' split_cols_by("ARMCD") %>%
|
|||
| 320 | +157 |
- } else {
+ #' split_rows_by("PARAMCD") %>%
|
||
| 321 | -40x | +|||
| 158 | +
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ #' summarize_num_patients( |
|||
| 322 | -40x | +|||
| 159 | +
- res_imp <- imputation_rule(+ #' var = "USUBJID", |
|||
| 323 | -40x | +|||
| 160 | +
- .df_row, x_stats, stat,+ #' .stats = "unique_count" |
|||
| 324 | -40x | +|||
| 161 | +
- imp_rule = imp_rule,+ #' ) %>% |
|||
| 325 | -40x | +|||
| 162 | +
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ #' split_rows_by( |
|||
| 326 | -40x | +|||
| 163 | +
- avalcat_var = avalcat_var+ #' "abn_dir", |
|||
| 327 | +164 |
- )+ #' split_fun = trim_levels_to_map(map) |
||
| 328 | -40x | +|||
| 165 | +
- res <- res_imp[["val"]]+ #' ) %>% |
|||
| 329 | -40x | +|||
| 166 | +
- na_str <- res_imp[["na_str"]]+ #' count_abnormal_by_marked( |
|||
| 330 | +167 |
- }+ #' var = "AVALCAT1", |
||
| 331 | +168 |
-
+ #' variables = list( |
||
| 332 | -210x | +|||
| 169 | +
- if (is.list(res)) {
+ #' id = "USUBJID", |
|||
| 333 | -19x | +|||
| 170 | +
- if (length(res) > 1) {
+ #' param = "PARAMCD", |
|||
| 334 | -1x | +|||
| 171 | +
- stop("The analyzed column produced more than one category of results.")
+ #' direction = "abn_dir" |
|||
| 335 | +172 |
- } else {
+ #' ) |
||
| 336 | -18x | +|||
| 173 | +
- res <- unlist(res)+ #' ) %>% |
|||
| 337 | +174 |
- }+ #' build_table(df = df) |
||
| 338 | +175 |
- }+ #' |
||
| 339 | +176 |
-
+ #' basic_table() %>% |
||
| 340 | +177 |
- # Label from context+ #' split_cols_by("ARMCD") %>%
|
||
| 341 | -209x | +|||
| 178 | +
- label_from_context <- .spl_context$value[nrow(.spl_context)]+ #' split_rows_by("PARAMCD") %>%
|
|||
| 342 | +179 |
-
+ #' summarize_num_patients( |
||
| 343 | +180 |
- # Label switcher+ #' var = "USUBJID", |
||
| 344 | -209x | +|||
| 181 | +
- if (is.null(row_labels)) {
+ #' .stats = "unique_count" |
|||
| 345 | -149x | +|||
| 182 | +
- lbl <- label_from_context+ #' ) %>% |
|||
| 346 | +183 |
- } else {
+ #' split_rows_by( |
||
| 347 | -60x | +|||
| 184 | +
- if (length(row_labels) > 1) {
+ #' "abn_dir", |
|||
| 348 | -48x | +|||
| 185 | +
- if (!(label_from_context %in% names(row_labels))) {
+ #' split_fun = trim_levels_in_group("abn_dir")
|
|||
| 349 | -! | +|||
| 186 | +
- stop(+ #' ) %>% |
|||
| 350 | -! | +|||
| 187 | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ #' count_abnormal_by_marked( |
|||
| 351 | -! | +|||
| 188 | +
- "that contains the split values. In the current split variable ",+ #' var = "AVALCAT1", |
|||
| 352 | -! | +|||
| 189 | +
- .spl_context$split[nrow(.spl_context)],+ #' variables = list( |
|||
| 353 | -! | +|||
| 190 | +
- " the split value ", label_from_context, " is not in",+ #' id = "USUBJID", |
|||
| 354 | -! | +|||
| 191 | +
- " row_labels names: ", names(row_labels)+ #' param = "PARAMCD", |
|||
| 355 | +192 |
- )+ #' direction = "abn_dir" |
||
| 356 | +193 |
- }+ #' ) |
||
| 357 | -48x | +|||
| 194 | +
- lbl <- unlist(row_labels[label_from_context])+ #' ) %>% |
|||
| 358 | +195 |
- } else {
+ #' build_table(df = df) |
||
| 359 | -12x | +|||
| 196 | +
- lbl <- row_labels+ #' |
|||
| 360 | +197 |
- }+ #' @export |
||
| 361 | +198 |
- }+ #' @order 2 |
||
| 362 | +199 |
-
+ count_abnormal_by_marked <- function(lyt, |
||
| 363 | +200 |
- # Cell creation+ var, |
||
| 364 | -209x | +|||
| 201 | +
- rcell(res,+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
|||
| 365 | -209x | +|||
| 202 | +
- label = lbl,+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"), |
|||
| 366 | -209x | +|||
| 203 | +
- format = formats_v[names(formats_v) == stat][[1]],+ na_str = default_na_str(), |
|||
| 367 | -209x | +|||
| 204 | +
- format_na_str = na_str,+ nested = TRUE, |
|||
| 368 | -209x | +|||
| 205 | +
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ ..., |
|||
| 369 | -209x | +|||
| 206 | +
- align = .aligns+ .stats = NULL, |
|||
| 370 | +207 |
- )+ .formats = NULL, |
||
| 371 | +208 |
- }+ .labels = NULL, |
||
| 372 | +209 |
- },+ .indent_mods = NULL) {
|
||
| 373 | -7x | +210 | +1x |
- stat = .stats,+ checkmate::assert_string(var) |
| 374 | -7x | +|||
| 211 | +
- use_cache = cache,+ |
|||
| 375 | -7x | +212 | +1x |
- cache_env = replicate(length(.stats), env)+ extra_args <- list(category = category, variables = variables, ...) |
| 376 | +213 |
- )+ |
||
| 377 | -+ | |||
| 214 | +1x |
-
+ afun <- make_afun( |
||
| 378 | -+ | |||
| 215 | +1x |
- # Main call to rtables+ a_count_abnormal_by_marked, |
||
| 379 | -7x | +216 | +1x |
- analyze_colvars(lyt,+ .stats = .stats, |
| 380 | -7x | +217 | +1x |
- afun = afun_list,+ .formats = .formats, |
| 381 | -7x | +218 | +1x |
- na_str = na_str,+ .labels = .labels, |
| 382 | -7x | +219 | +1x |
- nested = nested,+ .indent_mods = .indent_mods, |
| 383 | -7x | +220 | +1x |
- extra_args = extra_args+ .ungroup_stats = "count_fraction" |
| 384 | +221 |
- )+ ) |
||
| 385 | +222 |
- }+ |
||
| 386 | -+ | |||
| 223 | +1x |
- }+ lyt <- analyze( |
||
| 387 | -+ | |||
| 224 | +1x |
-
+ lyt = lyt, |
||
| 388 | -+ | |||
| 225 | +1x |
- # Help function+ vars = var,+ |
+ ||
| 226 | +1x | +
+ afun = afun,+ |
+ ||
| 227 | +1x | +
+ na_str = na_str,+ |
+ ||
| 228 | +1x | +
+ nested = nested,+ |
+ ||
| 229 | +1x | +
+ show_labels = "hidden",+ |
+ ||
| 230 | +1x | +
+ extra_args = extra_args |
||
| 389 | +231 |
- get_last_col_split <- function(lyt) {
+ ) |
||
| 390 | +232 | 1x |
- tail(tail(clayout(lyt), 1)[[1]], 1)[[1]]+ lyt |
|
| 391 | +233 |
}@@ -96214,14 +97543,14 @@ tern coverage - 90.46% |
| 1 |
- #' Tabulate Survival Duration by Subgroup+ #' Multivariate Logistic Regression Table |
||
| 5 |
- #' Tabulate statistics such as median survival time and hazard ratio for population subgroups.+ #' Layout-creating function which summarizes a logistic variable regression for binary outcome with |
||
| 6 |
- #'+ #' categorical/continuous covariates in model statement. For each covariate category (if categorical) |
||
| 7 |
- #' @inheritParams argument_convention+ #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and |
||
| 8 |
- #' @inheritParams survival_coxph_pairwise+ #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate |
||
| 9 |
- #' @param df (`list`)\cr of data frames containing all analysis variables. List should be+ #' category or specified values and corresponding Wald confidence intervals as default but allow user |
||
| 10 |
- #' created using [extract_survival_subgroups()].+ #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis |
||
| 11 |
- #' @param vars (`character`)\cr the name of statistics to be reported among:+ #' that covariate has no effect on response in model containing all specified covariates. |
||
| 12 |
- #' * `n_tot_events`: Total number of events per group.+ #' Allow option to include one two-way interaction and present similar output for |
||
| 13 |
- #' * `n_events`: Number of events per group.+ #' each interaction degree of freedom. |
||
| 14 |
- #' * `n_tot`: Total number of observations per group.+ #' |
||
| 15 |
- #' * `n`: Number of observations per group.+ #' @inheritParams argument_convention |
||
| 16 |
- #' * `median`: Median survival time.+ #' @param drop_and_remove_str (`character`)\cr string to be dropped and removed. |
||
| 17 |
- #' * `hr`: Hazard ratio.+ #' |
||
| 18 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 19 |
- #' * `pval`: p-value of the effect.+ #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout. |
||
| 20 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`+ #' |
||
| 21 |
- #' are required.+ #' @note For the formula, the variable names need to be standard `data.frame` column names without |
||
| 22 |
- #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit.+ #' special characters. |
||
| 24 |
- #' @details These functions create a layout starting from a data frame which contains+ #' @examples |
||
| 25 |
- #' the required statistics. Tables typically used as part of forest plot.+ #' library(dplyr) |
||
| 26 |
- #'+ #' library(broom) |
||
| 27 |
- #' @seealso [extract_survival_subgroups()]+ #' |
||
| 28 |
- #'+ #' adrs_f <- tern_ex_adrs %>% |
||
| 29 |
- #' @examples+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 30 |
- #' library(dplyr)+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 31 |
- #' library(forcats)+ #' mutate( |
||
| 32 |
- #'+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 33 |
- #' adtte <- tern_ex_adtte+ #' RACE = factor(RACE), |
||
| 34 |
- #'+ #' SEX = factor(SEX) |
||
| 35 |
- #' # Save variable labels before data processing steps.+ #' ) |
||
| 36 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 37 |
- #'+ #' mod1 <- fit_logistic( |
||
| 38 |
- #' adtte_f <- adtte %>%+ #' data = adrs_f, |
||
| 39 |
- #' filter(+ #' variables = list( |
||
| 40 |
- #' PARAMCD == "OS",+ #' response = "Response", |
||
| 41 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ #' arm = "ARMCD", |
||
| 42 |
- #' SEX %in% c("M", "F")
+ #' covariates = c("AGE", "RACE")
|
||
| 43 |
- #' ) %>%+ #' ) |
||
| 44 |
- #' mutate(+ #' ) |
||
| 45 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' mod2 <- fit_logistic( |
||
| 46 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ #' data = adrs_f, |
||
| 47 |
- #' SEX = droplevels(SEX),+ #' variables = list( |
||
| 48 |
- #' AVALU = as.character(AVALU),+ #' response = "Response", |
||
| 49 |
- #' is_event = CNSR == 0+ #' arm = "ARMCD", |
||
| 50 |
- #' )+ #' covariates = c("AGE", "RACE"),
|
||
| 51 |
- #' labels <- c(+ #' interaction = "AGE" |
||
| 52 |
- #' "ARM" = adtte_labels[["ARM"]],+ #' ) |
||
| 53 |
- #' "SEX" = adtte_labels[["SEX"]],+ #' ) |
||
| 54 |
- #' "AVALU" = adtte_labels[["AVALU"]],+ #' |
||
| 55 |
- #' "is_event" = "Event Flag"+ #' df <- tidy(mod1, conf_level = 0.99) |
||
| 56 |
- #' )+ #' df2 <- tidy(mod2, conf_level = 0.99) |
||
| 57 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' |
||
| 58 |
- #'+ #' # flagging empty strings with "_" |
||
| 59 |
- #' df <- extract_survival_subgroups(+ #' df <- df_explicit_na(df, na_level = "_") |
||
| 60 |
- #' variables = list(+ #' df2 <- df_explicit_na(df2, na_level = "_") |
||
| 61 |
- #' tte = "AVAL",+ #' |
||
| 62 |
- #' is_event = "is_event",+ #' result1 <- basic_table() %>% |
||
| 63 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ #' summarize_logistic( |
||
| 64 |
- #' ),+ #' conf_level = 0.95, |
||
| 65 |
- #' data = adtte_f+ #' drop_and_remove_str = "_" |
||
| 66 |
- #' )+ #' ) %>% |
||
| 67 |
- #' df+ #' build_table(df = df) |
||
| 68 |
- #'+ #' result1 |
||
| 69 |
- #' df_grouped <- extract_survival_subgroups(+ #' |
||
| 70 |
- #' variables = list(+ #' result2 <- basic_table() %>% |
||
| 71 |
- #' tte = "AVAL",+ #' summarize_logistic( |
||
| 72 |
- #' is_event = "is_event",+ #' conf_level = 0.95, |
||
| 73 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ #' drop_and_remove_str = "_" |
||
| 74 |
- #' ),+ #' ) %>% |
||
| 75 |
- #' data = adtte_f,+ #' build_table(df = df2) |
||
| 76 |
- #' groups_lists = list(+ #' result2 |
||
| 77 |
- #' BMRKR2 = list(+ #' |
||
| 78 |
- #' "low" = "LOW",+ #' @export |
||
| 79 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' @order 1 |
||
| 80 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ summarize_logistic <- function(lyt, |
||
| 81 |
- #' )+ conf_level, |
||
| 82 |
- #' )+ drop_and_remove_str = "", |
||
| 83 |
- #' )+ .indent_mods = NULL) {
|
||
| 84 |
- #' df_grouped+ # checks |
||
| 85 | -+ | 3x |
- #'+ checkmate::assert_string(drop_and_remove_str) |
| 86 |
- #' @name survival_duration_subgroups+ |
||
| 87 | -+ | 3x |
- #' @order 1+ sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
|
| 88 | -+ | 3x |
- NULL+ sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
|
| 89 | -+ | 3x |
-
+ sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
|
| 90 | -+ | 3x |
- #' Prepares Survival Data for Population Subgroups in Data Frames+ split_fun <- drop_and_remove_levels(drop_and_remove_str) |
| 91 |
- #'+ |
||
| 92 | -+ | 3x |
- #' @description `r lifecycle::badge("stable")`
+ lyt <- logistic_regression_cols(lyt, conf_level = conf_level) |
| 93 | -+ | 3x |
- #'+ lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun) |
| 94 | -+ | 3x |
- #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in+ lyt <- sum_logistic_variable_test(lyt) |
| 95 | -+ | 3x |
- #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list`+ lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun) |
| 96 | -+ | 3x |
- #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`,+ lyt <- sum_logistic_term_estimates(lyt) |
| 97 | -+ | 3x |
- #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strat`.+ lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun) |
| 98 | -+ | 3x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun) |
| 99 | -+ | 3x |
- #'+ lyt <- sum_logistic_odds_ratios(lyt) |
| 100 | -+ | 3x |
- #' @inheritParams argument_convention+ lyt |
| 101 |
- #' @inheritParams survival_duration_subgroups+ } |
||
| 102 |
- #' @inheritParams survival_coxph_pairwise+ |
||
| 103 |
- #'+ #' Fit for Logistic Regression |
||
| 104 |
- #' @return A named `list` of two elements:+ #' |
||
| 105 |
- #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`,+ #' @description `r lifecycle::badge("stable")`
|
||
| 106 |
- #' `var_label`, and `row_type`.+ #' |
||
| 107 |
- #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`,+ #' Fit a (conditional) logistic regression model. |
||
| 108 |
- #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ #' |
||
| 109 |
- #'+ #' @inheritParams argument_convention |
||
| 110 |
- #' @seealso [survival_duration_subgroups]+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 111 |
- #'+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
||
| 112 |
- #' @export+ #' This will be used when fitting the (conditional) logistic regression model on the left hand |
||
| 113 |
- extract_survival_subgroups <- function(variables,+ #' side of the formula. |
||
| 114 |
- data,+ #' |
||
| 115 |
- groups_lists = list(),+ #' @return A fitted logistic regression model. |
||
| 116 |
- control = control_coxph(),+ #' |
||
| 117 |
- label_all = "All Patients") {
+ #' @section Model Specification: |
||
| 118 | -9x | +
- df_survtime <- h_survtime_subgroups_df(+ #' |
|
| 119 | -9x | +
- variables,+ #' The `variables` list needs to include the following elements: |
|
| 120 | -9x | +
- data,+ #' * `arm`: Treatment arm variable name. |
|
| 121 | -9x | +
- groups_lists = groups_lists,+ #' * `response`: The response arm variable name. Usually this is a 0/1 variable. |
|
| 122 | -9x | +
- label_all = label_all+ #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names. |
|
| 123 |
- )+ #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already |
||
| 124 | -9x | +
- df_hr <- h_coxph_subgroups_df(+ #' included in `covariates`. Then the interaction with the treatment arm is included in the model. |
|
| 125 | -9x | +
- variables,+ #' |
|
| 126 | -9x | +
- data,+ #' @examples |
|
| 127 | -9x | +
- groups_lists = groups_lists,+ #' library(dplyr) |
|
| 128 | -9x | +
- control = control,+ #' |
|
| 129 | -9x | +
- label_all = label_all+ #' adrs_f <- tern_ex_adrs %>% |
|
| 130 |
- )+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 131 |
-
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 132 | -9x | +
- list(survtime = df_survtime, hr = df_hr)+ #' mutate( |
|
| 133 |
- }+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 134 |
-
+ #' RACE = factor(RACE), |
||
| 135 |
- #' @describeIn survival_duration_subgroups Formatted analysis function which is used as+ #' SEX = factor(SEX) |
||
| 136 |
- #' `afun` in `tabulate_survival_subgroups()`.+ #' ) |
||
| 137 |
- #'+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 138 |
- #' @return+ #' mod1 <- fit_logistic( |
||
| 139 |
- #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ #' data = adrs_f, |
||
| 140 |
- #'+ #' variables = list( |
||
| 141 |
- #' @keywords internal+ #' response = "Response", |
||
| 142 |
- a_survival_subgroups <- function(.formats = list( # nolint start+ #' arm = "ARMCD", |
||
| 143 |
- n = "xx",+ #' covariates = c("AGE", "RACE")
|
||
| 144 |
- n_events = "xx",+ #' ) |
||
| 145 |
- n_tot_events = "xx",+ #' ) |
||
| 146 |
- median = "xx.x",+ #' mod2 <- fit_logistic( |
||
| 147 |
- n_tot = "xx",+ #' data = adrs_f, |
||
| 148 |
- hr = list(format_extreme_values(2L)),+ #' variables = list( |
||
| 149 |
- ci = list(format_extreme_values_ci(2L)),+ #' response = "Response", |
||
| 150 |
- pval = "x.xxxx | (<0.0001)"+ #' arm = "ARMCD", |
||
| 151 |
- ),+ #' covariates = c("AGE", "RACE"),
|
||
| 152 |
- na_str = default_na_str()) { # nolint end
+ #' interaction = "AGE" |
||
| 153 | -15x | +
- checkmate::assert_list(.formats)+ #' ) |
|
| 154 | -15x | +
- checkmate::assert_subset(+ #' ) |
|
| 155 | -15x | +
- names(.formats),+ #' |
|
| 156 | -15x | +
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ #' @export |
|
| 157 |
- )+ fit_logistic <- function(data, |
||
| 158 |
-
+ variables = list( |
||
| 159 | -15x | +
- afun_lst <- Map(+ response = "Response", |
|
| 160 | -15x | +
- function(stat, fmt, na_str) {
+ arm = "ARMCD", |
|
| 161 | -114x | +
- if (stat == "ci") {
+ covariates = NULL, |
|
| 162 | -14x | +
- function(df, labelstr = "", ...) {
+ interaction = NULL, |
|
| 163 | -29x | +
- in_rows(+ strata = NULL |
|
| 164 | -29x | +
- .list = combine_vectors(df$lcl, df$ucl),+ ), |
|
| 165 | -29x | +
- .labels = as.character(df$subgroup),+ response_definition = "response") {
|
|
| 166 | -29x | +74x |
- .formats = fmt,+ assert_df_with_variables(data, variables) |
| 167 | -29x | +74x |
- .format_na_strs = na_str+ checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
|
| 168 | -+ | 74x |
- )+ checkmate::assert_string(response_definition) |
| 169 | -+ | 74x |
- }+ checkmate::assert_true(grepl("response", response_definition))
|
| 170 |
- } else {
+
|
||
| 171 | -100x | +74x |
- function(df, labelstr = "", ...) {
+ response_definition <- sub( |
| 172 | -159x | +74x |
- in_rows(+ pattern = "response", |
| 173 | -159x | +74x |
- .list = as.list(df[[stat]]),+ replacement = variables$response, |
| 174 | -159x | +74x |
- .labels = as.character(df$subgroup),+ x = response_definition, |
| 175 | -159x | +74x |
- .formats = fmt,+ fixed = TRUE |
| 176 | -159x | +
- .format_na_strs = na_str+ ) |
|
| 177 | -+ | 74x |
- )+ form <- paste0(response_definition, " ~ ", variables$arm) |
| 178 | -+ | 74x |
- }+ if (!is.null(variables$covariates)) {
|
| 179 | -+ | 28x |
- }+ form <- paste0(form, " + ", paste(variables$covariates, collapse = " + ")) |
| 180 |
- },+ } |
||
| 181 | -15x | +74x |
- stat = names(.formats),+ if (!is.null(variables$interaction)) {
|
| 182 | -15x | +17x |
- fmt = .formats,+ checkmate::assert_string(variables$interaction) |
| 183 | -15x | +17x |
- na_str = na_str+ checkmate::assert_subset(variables$interaction, variables$covariates) |
| 184 | -+ | 17x |
- )+ form <- paste0(form, " + ", variables$arm, ":", variables$interaction) |
| 185 |
-
+ } |
||
| 186 | -15x | +74x |
- afun_lst+ if (!is.null(variables$strata)) {
|
| 187 | -+ | 14x |
- }+ strata_arg <- if (length(variables$strata) > 1) {
|
| 188 | -+ | 7x |
-
+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
| 189 |
- #' @describeIn survival_duration_subgroups Table-creating function which creates a table+ } else {
|
||
| 190 | -+ | 7x |
- #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ variables$strata |
| 191 |
- #' and [rtables::summarize_row_groups()].+ } |
||
| 192 | -+ | 14x |
- #'+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
| 193 |
- #' @return An `rtables` table summarizing survival by subgroup.+ } |
||
| 194 | -+ | 74x |
- #'+ formula <- stats::as.formula(form) |
| 195 | -+ | 74x |
- #' @examples+ if (is.null(variables$strata)) {
|
| 196 | -+ | 60x |
- #' ## Table with default columns.+ stats::glm( |
| 197 | -+ | 60x |
- #' basic_table() %>%+ formula = formula, |
| 198 | -+ | 60x |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ data = data, |
| 199 | -+ | 60x |
- #'+ family = stats::binomial("logit")
|
| 200 |
- #' ## Table with a manually chosen set of columns: adding "pval".+ ) |
||
| 201 |
- #' basic_table() %>%+ } else {
|
||
| 202 | -+ | 14x |
- #' tabulate_survival_subgroups(+ clogit_with_tryCatch( |
| 203 | -+ | 14x |
- #' df = df,+ formula = formula, |
| 204 | -+ | 14x |
- #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
+ data = data, |
| 205 | -+ | 14x |
- #' time_unit = adtte_f$AVALU[1]+ x = TRUE |
| 206 |
- #' )+ ) |
||
| 207 |
- #'+ } |
||
| 208 |
- #' @export+ } |
||
| 209 |
- #' @order 2+ |
||
| 210 |
- tabulate_survival_subgroups <- function(lyt,+ #' Custom Tidy Method for Binomial GLM Results |
||
| 211 |
- df,+ #' |
||
| 212 |
- vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 213 |
- groups_lists = list(),+ #' |
||
| 214 |
- label_all = "All Patients",+ #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object |
||
| 215 |
- time_unit = NULL,+ #' with `binomial` family. |
||
| 216 |
- na_str = default_na_str()) {
+ #' |
||
| 217 | -6x | +
- conf_level <- df$hr$conf_level[1]+ #' @inheritParams argument_convention |
|
| 218 | -6x | +
- method <- df$hr$pval_label[1]+ #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise the median is used. |
|
| 219 |
-
+ #' @param x logistic regression model fitted by [stats::glm()] with "binomial" family. |
||
| 220 | -6x | +
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all)+ #' |
|
| 221 |
-
+ #' @return A `data.frame` containing the tidied model. |
||
| 222 | -6x | +
- afun_lst <- a_survival_subgroups(na_str = na_str)+ #' |
|
| 223 | -6x | +
- colvars <- d_survival_subgroups_colvars(+ #' @method tidy glm |
|
| 224 | -6x | +
- vars,+ #' |
|
| 225 | -6x | +
- conf_level = conf_level,+ #' @seealso [h_logistic_regression] for relevant helper functions. |
|
| 226 | -6x | +
- method = method,+ #' |
|
| 227 | -6x | +
- time_unit = time_unit+ #' @examples |
|
| 228 |
- )+ #' library(dplyr) |
||
| 229 |
-
+ #' library(broom) |
||
| 230 | -6x | +
- colvars_survtime <- list(+ #' |
|
| 231 | -6x | +
- vars = colvars$vars[names(colvars$labels) %in% c("n", "n_events", "median")],
+ #' adrs_f <- tern_ex_adrs %>% |
|
| 232 | -6x | +
- labels = colvars$labels[names(colvars$labels) %in% c("n", "n_events", "median")]
+ #' filter(PARAMCD == "BESRSPI") %>% |
|
| 233 |
- )+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 234 | -6x | +
- colvars_hr <- list(+ #' mutate( |
|
| 235 | -6x | +
- vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")],
+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
|
| 236 | -6x | +
- labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")]
+ #' RACE = factor(RACE), |
|
| 237 |
- )+ #' SEX = factor(SEX) |
||
| 238 |
-
+ #' ) |
||
| 239 |
- # Columns from table_survtime are optional.+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 240 | -6x | +
- if (length(colvars_survtime$vars) > 0) {
+ #' mod1 <- fit_logistic( |
|
| 241 | -5x | +
- lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")+ #' data = adrs_f, |
|
| 242 | -5x | +
- lyt_survtime <- split_rows_by(+ #' variables = list( |
|
| 243 | -5x | +
- lyt = lyt_survtime,+ #' response = "Response", |
|
| 244 | -5x | +
- var = "row_type",+ #' arm = "ARMCD", |
|
| 245 | -5x | +
- split_fun = keep_split_levels("content"),
+ #' covariates = c("AGE", "RACE")
|
|
| 246 | -5x | +
- nested = FALSE+ #' ) |
|
| 247 |
- )+ #' ) |
||
| 248 | -5x | +
- lyt_survtime <- summarize_row_groups(+ #' mod2 <- fit_logistic( |
|
| 249 | -5x | +
- lyt = lyt_survtime,+ #' data = adrs_f, |
|
| 250 | -5x | +
- var = "var_label",+ #' variables = list( |
|
| 251 | -5x | +
- cfun = afun_lst[names(colvars_survtime$labels)],+ #' response = "Response", |
|
| 252 | -5x | +
- na_str = na_str,+ #' arm = "ARMCD", |
|
| 253 | -5x | +
- extra_args = extra_args+ #' covariates = c("AGE", "RACE"),
|
|
| 254 |
- )+ #' interaction = "AGE" |
||
| 255 | -5x | +
- lyt_survtime <- split_cols_by_multivar(+ #' ) |
|
| 256 | -5x | +
- lyt = lyt_survtime,+ #' ) |
|
| 257 | -5x | +
- vars = colvars_survtime$vars,+ #' |
|
| 258 | -5x | +
- varlabels = colvars_survtime$labels+ #' df <- tidy(mod1, conf_level = 0.99) |
|
| 259 |
- )+ #' df2 <- tidy(mod2, conf_level = 0.99) |
||
| 260 |
-
+ #' |
||
| 261 | -5x | +
- if ("analysis" %in% df$survtime$row_type) {
+ #' @export |
|
| 262 | -4x | +
- lyt_survtime <- split_rows_by(+ tidy.glm <- function(x, # nolint |
|
| 263 | -4x | +
- lyt = lyt_survtime,+ conf_level = 0.95, |
|
| 264 | -4x | +
- var = "row_type",+ at = NULL, |
|
| 265 | -4x | +
- split_fun = keep_split_levels("analysis"),
+ ...) {
|
|
| 266 | -4x | +5x |
- nested = FALSE,+ checkmate::assert_class(x, "glm") |
| 267 | -4x | +5x |
- child_labels = "hidden"+ checkmate::assert_set_equal(x$family$family, "binomial") |
| 268 |
- )+ |
||
| 269 | -4x | +5x |
- lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)+ terms_name <- attr(stats::terms(x), "term.labels") |
| 270 | -4x | +5x |
- lyt_survtime <- analyze_colvars(+ xs_class <- attr(x$terms, "dataClasses") |
| 271 | -4x | +5x |
- lyt = lyt_survtime,+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
| 272 | -4x | +5x |
- afun = afun_lst[names(colvars_survtime$labels)],+ df <- if (length(interaction) == 0) {
|
| 273 | -4x | +2x |
- na_str = na_str,+ h_logistic_simple_terms( |
| 274 | -4x | +2x |
- inclNAs = TRUE,+ x = terms_name, |
| 275 | -4x | +2x |
- extra_args = extra_args+ fit_glm = x, |
| 276 | -+ | 2x |
- )+ conf_level = conf_level |
| 277 |
- }+ ) |
||
| 278 |
-
+ } else {
|
||
| 279 | -5x | +3x |
- table_survtime <- build_table(lyt_survtime, df = df$survtime)+ h_logistic_inter_terms( |
| 280 | -+ | 3x |
- } else {
+ x = terms_name, |
| 281 | -1x | +3x |
- table_survtime <- NULL+ fit_glm = x, |
| 282 | -+ | 3x |
- }+ conf_level = conf_level, |
| 283 | -+ | 3x |
-
+ at = at |
| 284 |
- # Columns "n_tot_events" or "n_tot", and "hr", "ci" in table_hr are required.+ ) |
||
| 285 | -6x | +
- lyt_hr <- split_cols_by(lyt = lyt, var = "arm")+ } |
|
| 286 | -6x | +5x |
- lyt_hr <- split_rows_by(+ for (var in c("variable", "term", "interaction", "reference")) {
|
| 287 | -6x | +20x |
- lyt = lyt_hr,+ df[[var]] <- factor(df[[var]], levels = unique(df[[var]])) |
| 288 | -6x | +
- var = "row_type",+ } |
|
| 289 | -6x | +5x |
- split_fun = keep_split_levels("content"),
+ df |
| 290 | -6x | +
- nested = FALSE+ } |
|
| 291 |
- )+ |
||
| 292 | -6x | +
- lyt_hr <- summarize_row_groups(+ #' Logistic Regression Multivariate Column Layout Function |
|
| 293 | -6x | +
- lyt = lyt_hr,+ #' |
|
| 294 | -6x | +
- var = "var_label",+ #' @description `r lifecycle::badge("stable")`
|
|
| 295 | -6x | +
- cfun = afun_lst[names(colvars_hr$labels)],+ #' |
|
| 296 | -6x | +
- na_str = na_str,+ #' Layout-creating function which creates a multivariate column layout summarizing logistic |
|
| 297 | -6x | +
- extra_args = extra_args+ #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()]. |
|
| 298 |
- )+ #' |
||
| 299 | -6x | +
- lyt_hr <- split_cols_by_multivar(+ #' @inheritParams argument_convention |
|
| 300 | -6x | +
- lyt = lyt_hr,+ #' |
|
| 301 | -6x | +
- vars = colvars_hr$vars,+ #' @return A layout object suitable for passing to further layouting functions. Adding this |
|
| 302 | -6x | +
- varlabels = colvars_hr$labels+ #' function to an `rtable` layout will split the table into columns corresponding to |
|
| 303 |
- ) %>%+ #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`. |
||
| 304 | -6x | +
- append_topleft("Baseline Risk Factors")
+ #' |
|
| 305 |
-
+ #' @export |
||
| 306 | -6x | +
- if ("analysis" %in% df$survtime$row_type) {
+ logistic_regression_cols <- function(lyt, |
|
| 307 | -5x | +
- lyt_hr <- split_rows_by(+ conf_level = 0.95) {
|
|
| 308 | -5x | +4x |
- lyt = lyt_hr,+ vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
|
| 309 | -5x | +4x |
- var = "row_type",+ var_labels <- c( |
| 310 | -5x | +4x |
- split_fun = keep_split_levels("analysis"),
+ df = "Degrees of Freedom", |
| 311 | -5x | +4x |
- nested = FALSE,+ estimate = "Parameter Estimate", |
| 312 | -5x | +4x |
- child_labels = "hidden"+ std_error = "Standard Error", |
| 313 | -+ | 4x |
- )+ odds_ratio = "Odds Ratio", |
| 314 | -5x | +4x |
- lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)+ ci = paste("Wald", f_conf_level(conf_level)),
|
| 315 | -5x | +4x |
- lyt_hr <- analyze_colvars(+ pvalue = "p-value" |
| 316 | -5x | +
- lyt = lyt_hr,+ ) |
|
| 317 | -5x | +4x |
- afun = afun_lst[names(colvars_hr$labels)],+ split_cols_by_multivar( |
| 318 | -5x | +4x |
- na_str = na_str,+ lyt = lyt, |
| 319 | -5x | +4x |
- inclNAs = TRUE,+ vars = vars, |
| 320 | -5x | +4x |
- extra_args = extra_args+ varlabels = var_labels |
| 321 |
- )+ ) |
||
| 322 |
- }+ } |
||
| 323 | -6x | +
- table_hr <- build_table(lyt_hr, df = df$hr)+ |
|
| 324 |
-
+ #' Logistic Regression Summary Table Constructor Function |
||
| 325 |
- # There can be one or two vars starting with "n_tot".+ #' |
||
| 326 | -6x | +
- n_tot_ids <- grep("^n_tot", colvars_hr$vars)
+ #' @description `r lifecycle::badge("stable")`
|
|
| 327 | -6x | +
- if (is.null(table_survtime)) {
+ #' |
|
| 328 | -1x | +
- result <- table_hr+ #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize |
|
| 329 | -1x | +
- hr_id <- match("hr", colvars_hr$vars)
+ #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()]. |
|
| 330 | -1x | +
- ci_id <- match("lcl", colvars_hr$vars)
+ #' |
|
| 331 |
- } else {
+ #' @inheritParams argument_convention |
||
| 332 |
- # Reorder the table.+ #' @param flag_var (`string`)\cr variable name identifying which row should be used in this |
||
| 333 | -5x | +
- result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])+ #' content function. |
|
| 334 |
- # And then calculate column indices accordingly.+ #' |
||
| 335 | -5x | +
- hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
+ #' @return A content function. |
|
| 336 | -5x | +
- ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("lcl", colvars_hr$vars[-n_tot_ids])
+ #' |
|
| 337 | -5x | +
- n_tot_ids <- seq_along(n_tot_ids)+ #' @export |
|
| 338 |
- }+ logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
|
||
| 339 | -+ | 10x |
-
+ checkmate::assert_string(flag_var) |
| 340 | -6x | +10x |
- structure(+ function(lyt) {
|
| 341 | -6x | +10x |
- result,+ cfun_list <- list( |
| 342 | -6x | +10x |
- forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
|
| 343 | -6x | +10x |
- col_x = hr_id,+ estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
| 344 | -6x | +10x |
- col_ci = ci_id,+ std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
| 345 | -+ | 10x |
- # Take the first one for scaling the symbol sizes in graph.+ odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
|
| 346 | -6x | +10x |
- col_symbol_size = n_tot_ids[1]+ ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
|
| 347 | -+ | 10x |
- )+ pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
|
| 348 |
- }+ ) |
||
| 349 | -+ | 10x |
-
+ summarize_row_groups( |
| 350 | -+ | 10x |
- #' Labels for Column Variables in Survival Duration by Subgroup Table+ lyt = lyt, |
| 351 | -+ | 10x |
- #'+ cfun = cfun_list, |
| 352 | -+ | 10x |
- #' @description `r lifecycle::badge("stable")`
+ na_str = na_str |
| 353 |
- #'+ ) |
||
| 354 |
- #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels.+ } |
||
| 355 |
- #'+ } |
| 356 | +1 |
- #' @inheritParams tabulate_survival_subgroups+ #' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations |
||
| 357 | +2 |
- #' @inheritParams argument_convention+ #' |
||
| 358 | +3 |
- #' @param method (`character`)\cr p-value method for testing hazard ratio = 1.+ #' @description `r lifecycle::badge("stable")`
|
||
| 359 | +4 |
#' |
||
| 360 | +5 |
- #' @return A `list` of variables and their labels to tabulate.+ #' Helper functions that are used internally for the STEP calculations. |
||
| 361 | +6 |
#' |
||
| 362 | +7 |
- #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`.+ #' @inheritParams argument_convention |
||
| 363 | +8 |
#' |
||
| 364 | +9 |
- #' @export+ #' @name h_step |
||
| 365 | +10 |
- d_survival_subgroups_colvars <- function(vars,+ #' @include control_step.R |
||
| 366 | +11 |
- conf_level,+ NULL |
||
| 367 | +12 |
- method,+ |
||
| 368 | +13 |
- time_unit = NULL) {
- |
- ||
| 369 | -15x | -
- checkmate::assert_character(vars)- |
- ||
| 370 | -15x | -
- checkmate::assert_string(time_unit, null.ok = TRUE)- |
- ||
| 371 | -15x | -
- checkmate::assert_subset(c("hr", "ci"), vars)
- |
- ||
| 372 | -15x | -
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
- |
- ||
| 373 | -15x | -
- checkmate::assert_subset(+ #' @describeIn h_step creates the windows for STEP, based on the control settings |
||
| 374 | -15x | +|||
| 14 | +
- vars,+ #' provided. |
|||
| 375 | -15x | +|||
| 15 | +
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ #' |
|||
| 376 | +16 |
- )+ #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`). |
||
| 377 | +17 |
-
+ #' @param control (named `list`)\cr output from `control_step()`. |
||
| 378 | -15x | +|||
| 18 | +
- propcase_time_label <- if (!is.null(time_unit)) {
+ #' |
|||
| 379 | -14x | +|||
| 19 | +
- paste0("Median (", time_unit, ")")
+ #' @return |
|||
| 380 | +20 |
- } else {
+ #' * `h_step_window()` returns a list containing the window-selection matrix `sel` |
||
| 381 | -1x | +|||
| 21 | +
- "Median"+ #' and the interval information matrix `interval`. |
|||
| 382 | +22 |
- }+ #' |
||
| 383 | +23 |
-
+ #' @export |
||
| 384 | -15x | +|||
| 24 | +
- varlabels <- c(+ h_step_window <- function(x, |
|||
| 385 | -15x | +|||
| 25 | +
- n = "n",+ control = control_step()) {
|
|||
| 386 | -15x | +26 | +12x |
- n_events = "Events",+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
| 387 | -15x | +27 | +12x |
- median = propcase_time_label,+ checkmate::assert_list(control, names = "named") |
| 388 | -15x | +|||
| 28 | +
- n_tot = "Total n",+ |
|||
| 389 | -15x | +29 | +12x |
- n_tot_events = "Total Events",+ sel <- matrix(FALSE, length(x), control$num_points) |
| 390 | -15x | +30 | +12x |
- hr = "Hazard Ratio",+ out <- matrix(0, control$num_points, 3) |
| 391 | -15x | +31 | +12x |
- ci = paste0(100 * conf_level, "% Wald CI"),+ colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
|
| 392 | -15x | +32 | +12x |
- pval = method+ if (control$use_percentile) {
|
| 393 | +33 |
- )+ # Create windows according to percentile cutoffs. |
||
| 394 | -+ | |||
| 34 | +9x |
-
+ out <- cbind(out, out) |
||
| 395 | -15x | +35 | +9x |
- colvars <- vars+ colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
|
| 396 | -+ | |||
| 36 | +9x |
-
+ xs <- seq(0, 1, length = control$num_points + 2)[-1] |
||
| 397 | -+ | |||
| 37 | +9x |
- # The `lcl` variable is just a placeholder available in the analysis data,+ for (i in seq_len(control$num_points)) {
|
||
| 398 | -+ | |||
| 38 | +185x |
- # it is not acutally used in the tabulation.+ out[i, 2:3] <- c( |
||
| 399 | -+ | |||
| 39 | +185x |
- # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.+ max(xs[i] - control$bandwidth, 0), |
||
| 400 | -15x | +40 | +185x |
- colvars[colvars == "ci"] <- "lcl"+ min(xs[i] + control$bandwidth, 1) |
| 401 | +41 | - - | -||
| 402 | -15x | -
- list(+ ) |
||
| 403 | -15x | +42 | +185x |
- vars = colvars,+ out[i, 5:6] <- stats::quantile(x, out[i, 2:3]) |
| 404 | -15x | -
- labels = varlabels[vars]- |
- ||
| 405 | -+ | 43 | +185x |
- )+ sel[, i] <- x >= out[i, 5] & x <= out[i, 6] |
| 406 | +44 |
- }+ } |
| 1 | +45 |
- #' Control function for incidence rate+ # Center is the middle point of the percentile window. |
||
| 2 | -+ | |||
| 46 | +9x |
- #'+ out[, 1] <- xs[-control$num_points - 1] |
||
| 3 | -+ | |||
| 47 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ out[, 4] <- stats::quantile(x, out[, 1]) |
||
| 4 | +48 |
- #'+ } else {
|
||
| 5 | +49 |
- #' This is an auxiliary function for controlling arguments for the incidence rate, used+ # Create windows according to cutoffs. |
||
| 6 | -+ | |||
| 50 | +3x |
- #' internally to specify details in `s_incidence_rate()`.+ m <- c(min(x), max(x)) |
||
| 7 | -+ | |||
| 51 | +3x |
- #'+ xs <- seq(m[1], m[2], length = control$num_points + 2)[-1] |
||
| 8 | -+ | |||
| 52 | +3x |
- #' @inheritParams argument_convention+ for (i in seq_len(control$num_points)) {
|
||
| 9 | -+ | |||
| 53 | +11x |
- #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ out[i, 2:3] <- c( |
||
| 10 | -+ | |||
| 54 | +11x |
- #' for confidence interval type.+ max(xs[i] - control$bandwidth, m[1]), |
||
| 11 | -+ | |||
| 55 | +11x |
- #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default)+ min(xs[i] + control$bandwidth, m[2]) |
||
| 12 | +56 |
- #' indicating time unit for data input.+ ) |
||
| 13 | -+ | |||
| 57 | +11x |
- #' @param num_pt_year (`numeric`)\cr number of patient-years to use when calculating adverse event rates.+ sel[, i] <- x >= out[i, 2] & x <= out[i, 3] |
||
| 14 | +58 |
- #' @param time_unit_input `r lifecycle::badge("deprecated")` Please use the `input_time_unit` argument instead.
+ } |
||
| 15 | +59 |
- #' @param time_unit_output `r lifecycle::badge("deprecated")` Please use the `num_pt_year` argument instead.
+ # Center is the same as the point for predicting. |
||
| 16 | -+ | |||
| 60 | +3x |
- #'+ out[, 1] <- xs[-control$num_points - 1] |
||
| 17 | +61 |
- #' @return A list of components with the same names as the arguments.+ } |
||
| 18 | -+ | |||
| 62 | +12x |
- #'+ list(sel = sel, interval = out) |
||
| 19 | +63 |
- #' @seealso [incidence_rate]+ } |
||
| 20 | +64 |
- #'+ |
||
| 21 | +65 |
- #' @examples+ #' @describeIn h_step calculates the estimated treatment effect estimate |
||
| 22 | +66 |
- #' control_incidence_rate(0.9, "exact", "month", 100)+ #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted |
||
| 23 | +67 |
- #'+ #' on `data` given `variables` specification, for a single biomarker value `x`. |
||
| 24 | +68 |
- #' @export+ #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds |
||
| 25 | +69 |
- control_incidence_rate <- function(conf_level = 0.95,+ #' ratio estimates. |
||
| 26 | +70 |
- conf_type = c("normal", "normal_log", "exact", "byar"),
+ #' |
||
| 27 | +71 |
- input_time_unit = c("year", "day", "week", "month"),
+ #' @param model the regression model object. |
||
| 28 | +72 |
- num_pt_year = 100,+ #' |
||
| 29 | +73 |
- time_unit_input = lifecycle::deprecated(),+ #' @return |
||
| 30 | +74 |
- time_unit_output = lifecycle::deprecated()) {
- |
- ||
| 31 | -8x | -
- if (lifecycle::is_present(time_unit_input)) {
- |
- ||
| 32 | -! | -
- lifecycle::deprecate_warn(- |
- ||
| 33 | -! | -
- "0.8.3", "control_incidence_rate(time_unit_input)", "control_incidence_rate(input_time_unit)"+ #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`. |
||
| 34 | +75 |
- )- |
- ||
| 35 | -! | -
- input_time_unit <- time_unit_input+ #' |
||
| 36 | +76 |
- }- |
- ||
| 37 | -8x | -
- if (lifecycle::is_present(time_unit_output)) {
- |
- ||
| 38 | -! | -
- lifecycle::deprecate_warn(- |
- ||
| 39 | -! | -
- "0.8.3", "control_incidence_rate(time_unit_output)", "control_incidence_rate(num_pt_year)"+ #' @export |
||
| 40 | +77 |
- )- |
- ||
| 41 | -! | -
- num_pt_year <- time_unit_output+ h_step_trt_effect <- function(data, |
||
| 42 | +78 |
- }+ model, |
||
| 43 | +79 | - - | -||
| 44 | -8x | -
- conf_type <- match.arg(conf_type)- |
- ||
| 45 | -7x | -
- input_time_unit <- match.arg(input_time_unit)- |
- ||
| 46 | -6x | -
- checkmate::assert_number(num_pt_year)- |
- ||
| 47 | -5x | -
- assert_proportion_value(conf_level)+ variables, |
||
| 48 | +80 | - - | -||
| 49 | -4x | -
- list(- |
- ||
| 50 | -4x | -
- conf_level = conf_level,+ x) {
|
||
| 51 | -4x | +81 | +208x |
- conf_type = conf_type,+ checkmate::assert_multi_class(model, c("coxph", "glm"))
|
| 52 | -4x | +82 | +208x |
- input_time_unit = input_time_unit,+ checkmate::assert_number(x) |
| 53 | -4x | -
- num_pt_year = num_pt_year- |
- ||
| 54 | -- |
- )- |
- ||
| 55 | -- |
- }- |
-
| 1 | -- |
- #' Tabulate Biomarker Effects on Survival by Subgroup- |
- ||
| 2 | -+ | 83 | +208x |
- #'+ assert_df_with_variables(data, variables) |
| 3 | -+ | |||
| 84 | +208x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_factor(data[[variables$arm]], n.levels = 2) |
||
| 4 | +85 |
- #'+ |
||
| 5 | -+ | |||
| 86 | +208x |
- #' Tabulate the estimated effects of multiple continuous biomarker variables+ newdata <- data[c(1, 1), ] |
||
| 6 | -+ | |||
| 87 | +208x |
- #' across population subgroups.+ newdata[, variables$biomarker] <- x |
||
| 7 | -+ | |||
| 88 | +208x |
- #'+ newdata[, variables$arm] <- levels(data[[variables$arm]]) |
||
| 8 | -+ | |||
| 89 | +208x |
- #' @inheritParams fit_coxreg_multivar+ model_terms <- stats::delete.response(stats::terms(model)) |
||
| 9 | -+ | |||
| 90 | +208x |
- #' @inheritParams survival_duration_subgroups+ model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels) |
||
| 10 | -+ | |||
| 91 | +208x |
- #' @inheritParams argument_convention+ mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts) |
||
| 11 | -+ | |||
| 92 | +208x |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ coefs <- stats::coef(model) |
||
| 12 | +93 |
- #' [extract_survival_biomarkers()].+ # Note: It is important to use the coef subset from matrix, otherwise intercept and |
||
| 13 | +94 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ # strata are included for coxph() models. |
||
| 14 | -+ | |||
| 95 | +208x |
- #' * `n_tot_events`: Total number of events per group.+ mat <- mat[, names(coefs)] |
||
| 15 | -+ | |||
| 96 | +208x |
- #' * `n_tot`: Total number of observations per group.+ mat_diff <- diff(mat) |
||
| 16 | -+ | |||
| 97 | +208x |
- #' * `median`: Median survival time.+ est <- mat_diff %*% coefs |
||
| 17 | -+ | |||
| 98 | +208x |
- #' * `hr`: Hazard ratio.+ var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff) |
||
| 18 | -+ | |||
| 99 | +208x |
- #' * `ci`: Confidence interval of hazard ratio.+ se <- sqrt(var) |
||
| 19 | -+ | |||
| 100 | +208x |
- #' * `pval`: p-value of the effect.+ c( |
||
| 20 | -+ | |||
| 101 | +208x |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required.+ est = est, |
||
| 21 | -+ | |||
| 102 | +208x |
- #'+ se = se |
||
| 22 | +103 |
- #' @details These functions create a layout starting from a data frame which contains+ ) |
||
| 23 | +104 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ } |
||
| 24 | +105 |
- #'+ |
||
| 25 | +106 |
- #' @examples+ #' @describeIn h_step builds the model formula used in survival STEP calculations. |
||
| 26 | +107 |
- #' library(dplyr)+ #' |
||
| 27 | +108 |
- #'+ #' @return |
||
| 28 | +109 |
- #' adtte <- tern_ex_adtte+ #' * `h_step_survival_formula()` returns a model formula. |
||
| 29 | +110 |
#' |
||
| 30 | +111 |
- #' # Save variable labels before data processing steps.+ #' @export |
||
| 31 | +112 |
- #' adtte_labels <- formatters::var_labels(adtte)+ h_step_survival_formula <- function(variables, |
||
| 32 | +113 |
- #'+ control = control_step()) {
|
||
| 33 | -+ | |||
| 114 | +10x |
- #' adtte_f <- adtte %>%+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
||
| 34 | +115 |
- #' filter(PARAMCD == "OS") %>%+ |
||
| 35 | -+ | |||
| 116 | +10x |
- #' mutate(+ assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
|
||
| 36 | -+ | |||
| 117 | +10x |
- #' AVALU = as.character(AVALU),+ form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
|
||
| 37 | -+ | |||
| 118 | +10x |
- #' is_event = CNSR == 0+ if (control$degree > 0) {
|
||
| 38 | -+ | |||
| 119 | +5x |
- #' )+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
|
||
| 39 | +120 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ } |
||
| 40 | -+ | |||
| 121 | +10x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ if (!is.null(variables$covariates)) {
|
||
| 41 | -+ | |||
| 122 | +6x |
- #'+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
||
| 42 | +123 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ } |
||
| 43 | -+ | |||
| 124 | +10x |
- #' # in multiple regression models containing one covariate `RACE`,+ if (!is.null(variables$strata)) {
|
||
| 44 | -+ | |||
| 125 | +2x |
- #' # as well as one stratification variable `STRATA1`. The subgroups+ form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
||
| 45 | +126 |
- #' # are defined by the levels of `BMRKR2`.+ } |
||
| 46 | -+ | |||
| 127 | +10x |
- #'+ stats::as.formula(form) |
||
| 47 | +128 |
- #' df <- extract_survival_biomarkers(+ } |
||
| 48 | +129 |
- #' variables = list(+ |
||
| 49 | +130 |
- #' tte = "AVAL",+ #' @describeIn h_step estimates the model with `formula` built based on |
||
| 50 | +131 |
- #' is_event = "is_event",+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
||
| 51 | +132 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' Cox regression. |
||
| 52 | +133 |
- #' strata = "STRATA1",+ #' |
||
| 53 | +134 |
- #' covariates = "SEX",+ #' @param formula (`formula`)\cr the regression model formula. |
||
| 54 | +135 |
- #' subgroups = "BMRKR2"+ #' @param subset (`logical`)\cr subset vector. |
||
| 55 | +136 |
- #' ),+ #' |
||
| 56 | +137 |
- #' data = adtte_f+ #' @return |
||
| 57 | +138 |
- #' )+ #' * `h_step_survival_est()` returns a matrix of number of observations `n`, |
||
| 58 | +139 |
- #' df+ #' `events`, log hazard ratio estimates `loghr`, standard error `se`, |
||
| 59 | +140 |
- #'+ #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is |
||
| 60 | +141 |
- #' # Here we group the levels of `BMRKR2` manually.+ #' included for each biomarker value in `x`. |
||
| 61 | +142 |
- #' df_grouped <- extract_survival_biomarkers(+ #' |
||
| 62 | +143 |
- #' variables = list(+ #' @export |
||
| 63 | +144 |
- #' tte = "AVAL",+ h_step_survival_est <- function(formula, |
||
| 64 | +145 |
- #' is_event = "is_event",+ data, |
||
| 65 | +146 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ variables, |
||
| 66 | +147 |
- #' strata = "STRATA1",+ x, |
||
| 67 | +148 |
- #' covariates = "SEX",+ subset = rep(TRUE, nrow(data)), |
||
| 68 | +149 |
- #' subgroups = "BMRKR2"+ control = control_coxph()) {
|
||
| 69 | -+ | |||
| 150 | +55x |
- #' ),+ checkmate::assert_formula(formula) |
||
| 70 | -+ | |||
| 151 | +55x |
- #' data = adtte_f,+ assert_df_with_variables(data, variables) |
||
| 71 | -+ | |||
| 152 | +55x |
- #' groups_lists = list(+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
||
| 72 | -+ | |||
| 153 | +55x |
- #' BMRKR2 = list(+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
||
| 73 | -+ | |||
| 154 | +55x |
- #' "low" = "LOW",+ checkmate::assert_list(control, names = "named") |
||
| 74 | +155 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+
|
||
| 75 | +156 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ # Note: `subset` in `coxph` needs to be an expression referring to `data` variables. |
||
| 76 | -+ | |||
| 157 | +55x |
- #' )+ data$.subset <- subset |
||
| 77 | -+ | |||
| 158 | +55x |
- #' )+ coxph_warnings <- NULL |
||
| 78 | -+ | |||
| 159 | +55x |
- #' )+ tryCatch( |
||
| 79 | -+ | |||
| 160 | +55x |
- #' df_grouped+ withCallingHandlers( |
||
| 80 | -+ | |||
| 161 | +55x |
- #'+ expr = {
|
||
| 81 | -+ | |||
| 162 | +55x |
- #' @name survival_biomarkers_subgroups+ fit <- survival::coxph( |
||
| 82 | -+ | |||
| 163 | +55x |
- #' @order 1+ formula = formula, |
||
| 83 | -+ | |||
| 164 | +55x |
- NULL+ data = data, |
||
| 84 | -+ | |||
| 165 | +55x |
-
+ subset = .subset, |
||
| 85 | -+ | |||
| 166 | +55x |
- #' Prepares Survival Data Estimates for Multiple Biomarkers in a Single Data Frame+ ties = control$ties |
||
| 86 | +167 |
- #'+ ) |
||
| 87 | +168 |
- #' @description `r lifecycle::badge("stable")`
+ }, |
||
| 88 | -+ | |||
| 169 | +55x |
- #'+ warning = function(w) {
|
||
| 89 | -+ | |||
| 170 | +1x |
- #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates,+ coxph_warnings <<- c(coxph_warnings, w) |
||
| 90 | -+ | |||
| 171 | +1x |
- #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame.+ invokeRestart("muffleWarning")
|
||
| 91 | +172 |
- #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements+ } |
||
| 92 | +173 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strat`.+ ), |
||
| 93 | -+ | |||
| 174 | +55x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ finally = {
|
||
| 94 | +175 |
- #'+ } |
||
| 95 | +176 |
- #' @inheritParams argument_convention+ ) |
||
| 96 | -+ | |||
| 177 | +55x |
- #' @inheritParams fit_coxreg_multivar+ if (!is.null(coxph_warnings)) {
|
||
| 97 | -+ | |||
| 178 | +1x |
- #' @inheritParams survival_duration_subgroups+ warning(paste( |
||
| 98 | -+ | |||
| 179 | +1x |
- #'+ "Fit warnings occurred, please consider using a simpler model, or", |
||
| 99 | -+ | |||
| 180 | +1x |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`,+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
||
| 100 | +181 |
- #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ )) |
||
| 101 | +182 |
- #' `var_label`, and `row_type`.+ } |
||
| 102 | +183 |
- #'+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
||
| 103 | -+ | |||
| 184 | +55x |
- #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()].+ estimates <- t(vapply( |
||
| 104 | -+ | |||
| 185 | +55x |
- #'+ X = x, |
||
| 105 | -+ | |||
| 186 | +55x |
- #' @export+ FUN = h_step_trt_effect, |
||
| 106 | -+ | |||
| 187 | +55x |
- extract_survival_biomarkers <- function(variables,+ FUN.VALUE = c(1, 2), |
||
| 107 | -+ | |||
| 188 | +55x |
- data,+ data = data, |
||
| 108 | -+ | |||
| 189 | +55x |
- groups_lists = list(),+ model = fit, |
||
| 109 | -+ | |||
| 190 | +55x |
- control = control_coxreg(),+ variables = variables |
||
| 110 | +191 |
- label_all = "All Patients") {
+ )) |
||
| 111 | -5x | +192 | +55x |
- checkmate::assert_list(variables)+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
| 112 | -5x | +193 | +55x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ cbind( |
| 113 | -5x | +194 | +55x |
- checkmate::assert_string(label_all)+ n = fit$n, |
| 114 | -+ | |||
| 195 | +55x |
-
+ events = fit$nevent, |
||
| 115 | -+ | |||
| 196 | +55x |
- # Start with all patients.+ loghr = estimates[, "est"], |
||
| 116 | -5x | +197 | +55x |
- result_all <- h_coxreg_mult_cont_df(+ se = estimates[, "se"], |
| 117 | -5x | +198 | +55x |
- variables = variables,+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
| 118 | -5x | +199 | +55x |
- data = data,+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
| 119 | -5x | +|||
| 200 | +
- control = control+ ) |
|||
| 120 | +201 |
- )+ } |
||
| 121 | -5x | +|||
| 202 | +
- result_all$subgroup <- label_all+ |
|||
| 122 | -5x | +|||
| 203 | +
- result_all$var <- "ALL"+ #' @describeIn h_step builds the model formula used in response STEP calculations. |
|||
| 123 | -5x | +|||
| 204 | +
- result_all$var_label <- label_all+ #' |
|||
| 124 | -5x | +|||
| 205 | +
- result_all$row_type <- "content"+ #' @return |
|||
| 125 | -5x | +|||
| 206 | +
- if (is.null(variables$subgroups)) {
+ #' * `h_step_rsp_formula()` returns a model formula. |
|||
| 126 | +207 |
- # Only return result for all patients.+ #' |
||
| 127 | -1x | +|||
| 208 | +
- result_all+ #' @export |
|||
| 128 | +209 |
- } else {
+ h_step_rsp_formula <- function(variables, |
||
| 129 | +210 |
- # Add subgroups results.+ control = c(control_step(), control_logistic())) {
|
||
| 130 | -4x | +211 | +14x |
- l_data <- h_split_by_subgroups(+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 131 | -4x | +212 | +14x |
- data,+ assert_list_of_variables(variables[c("arm", "biomarker", "response")])
|
| 132 | -4x | +213 | +14x |
- variables$subgroups,+ response_definition <- sub( |
| 133 | -4x | +214 | +14x |
- groups_lists = groups_lists+ pattern = "response", |
| 134 | -+ | |||
| 215 | +14x |
- )+ replacement = variables$response, |
||
| 135 | -4x | +216 | +14x |
- l_result <- lapply(l_data, function(grp) {
+ x = control$response_definition, |
| 136 | -20x | +217 | +14x |
- result <- h_coxreg_mult_cont_df(+ fixed = TRUE+ |
+
| 218 | ++ |
+ ) |
||
| 137 | -20x | +219 | +14x |
- variables = variables,+ form <- paste0(response_definition, " ~ ", variables$arm) |
| 138 | -20x | +220 | +14x |
- data = grp$df,+ if (control$degree > 0) {
|
| 139 | -20x | +221 | +8x |
- control = control+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
|
| 140 | +222 |
- )+ } |
||
| 141 | -20x | +223 | +14x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ if (!is.null(variables$covariates)) {
|
| 142 | -20x | +224 | +8x |
- cbind(result, result_labels)+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
| 143 | +225 |
- })+ } |
||
| 144 | -4x | +226 | +14x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ if (!is.null(variables$strata)) {
|
| 145 | -4x | +227 | +5x |
- result_subgroups$row_type <- "analysis"+ strata_arg <- if (length(variables$strata) > 1) {
|
| 146 | -4x | +228 | +2x |
- rbind(+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
| 147 | -4x | +|||
| 229 | +
- result_all,+ } else {
|
|||
| 148 | -4x | +230 | +3x |
- result_subgroups+ variables$strata |
| 149 | +231 |
- )+ }+ |
+ ||
| 232 | +5x | +
+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
||
| 150 | +233 |
} |
||
| 234 | +14x | +
+ stats::as.formula(form)+ |
+ ||
| 151 | +235 |
} |
||
| 152 | +236 | |||
| 153 | +237 |
- #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table+ #' @describeIn h_step estimates the model with `formula` built based on |
||
| 154 | +238 |
- #' summarizing biomarker effects on survival by subgroup.+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
||
| 155 | +239 |
- #'+ #' logistic regression. |
||
| 156 | +240 |
- #' @return An `rtables` table summarizing biomarker effects on survival by subgroup.+ #' |
||
| 157 | +241 |
- #'+ #' @param formula (`formula`)\cr the regression model formula. |
||
| 158 | +242 |
- #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does+ #' @param subset (`logical`)\cr subset vector. |
||
| 159 | +243 |
- #' not start from an input layout `lyt`. This is because internally the table is+ #' |
||
| 160 | +244 |
- #' created by combining multiple subtables.+ #' @return |
||
| 161 | +245 |
- #'+ #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds |
||
| 162 | +246 |
- #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()].+ #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds |
||
| 163 | +247 |
- #'+ #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`. |
||
| 164 | +248 |
- #' @examples+ #' |
||
| 165 | +249 |
- #' ## Table with default columns.+ #' @export |
||
| 166 | +250 |
- #' tabulate_survival_biomarkers(df)+ h_step_rsp_est <- function(formula, |
||
| 167 | +251 |
- #'+ data, |
||
| 168 | +252 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ variables, |
||
| 169 | +253 |
- #' tab <- tabulate_survival_biomarkers(+ x, |
||
| 170 | +254 |
- #' df = df,+ subset = rep(TRUE, nrow(data)), |
||
| 171 | +255 |
- #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
+ control = control_logistic()) {
|
||
| 172 | -+ | |||
| 256 | +58x |
- #' time_unit = as.character(adtte_f$AVALU[1])+ checkmate::assert_formula(formula) |
||
| 173 | -+ | |||
| 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) |
||
| 174 | -+ | |||
| 260 | +58x |
- #'+ checkmate::assert_list(control, names = "named") |
||
| 175 | +261 |
- #' ## Finally produce the forest plot.+ # Note: `subset` in `glm` needs to be an expression referring to `data` variables. |
||
| 176 | -+ | |||
| 262 | +58x |
- #' \donttest{
+ data$.subset <- subset |
||
| 177 | -+ | |||
| 263 | +58x |
- #' g_forest(tab, xlim = c(0.8, 1.2))+ fit_warnings <- NULL |
||
| 178 | -+ | |||
| 264 | +58x |
- #' }+ tryCatch( |
||
| 179 | -+ | |||
| 265 | +58x |
- #'+ withCallingHandlers( |
||
| 180 | -+ | |||
| 266 | +58x |
- #' @export+ expr = {
|
||
| 181 | -+ | |||
| 267 | +58x |
- #' @order 2+ fit <- if (is.null(variables$strata)) {
|
||
| 182 | -+ | |||
| 268 | +54x |
- tabulate_survival_biomarkers <- function(df,+ stats::glm( |
||
| 183 | -+ | |||
| 269 | +54x |
- vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ formula = formula, |
||
| 184 | -+ | |||
| 270 | +54x |
- groups_lists = list(),+ data = data, |
||
| 185 | -+ | |||
| 271 | +54x |
- control = control_coxreg(),+ subset = .subset, |
||
| 186 | -+ | |||
| 272 | +54x |
- label_all = "All Patients",+ family = stats::binomial("logit")
|
||
| 187 | +273 |
- time_unit = NULL,+ ) |
||
| 188 | +274 |
- na_str = default_na_str(),+ } else {
|
||
| 189 | +275 |
- .indent_mods = 0L) {
+ # clogit needs coxph and strata imported |
||
| 190 | +276 | 4x |
- checkmate::assert_data_frame(df)+ survival::clogit( |
|
| 191 | +277 | 4x |
- checkmate::assert_character(df$biomarker)+ formula = formula, |
|
| 192 | +278 | 4x |
- checkmate::assert_character(df$biomarker_label)+ data = data, |
|
| 193 | +279 | 4x |
- checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
+ subset = .subset |
|
| 194 | +280 |
-
+ ) |
||
| 195 | -4x | +|||
| 281 | +
- extra_args <- list(groups_lists = groups_lists, control = control, label_all = label_all)+ } |
|||
| 196 | +282 |
-
+ }, |
||
| 197 | -4x | +283 | +58x |
- df_subs <- split(df, f = df$biomarker)+ warning = function(w) {
|
| 198 | -4x | +284 | +19x |
- tabs <- lapply(df_subs, FUN = function(df_sub) {
+ fit_warnings <<- c(fit_warnings, w) |
| 199 | -7x | +285 | +19x |
- tab_sub <- h_tab_surv_one_biomarker(+ invokeRestart("muffleWarning")
|
| 200 | -7x | +|||
| 286 | +
- df = df_sub,+ }+ |
+ |||
| 287 | ++ |
+ ), |
||
| 201 | -7x | +288 | +58x |
- vars = vars,+ finally = {
+ |
+
| 289 | ++ |
+ }+ |
+ ||
| 290 | ++ |
+ ) |
||
| 202 | -7x | +291 | +58x |
- time_unit = time_unit,+ if (!is.null(fit_warnings)) {
|
| 203 | -7x | +292 | +13x |
- na_str = na_str,+ warning(paste( |
| 204 | -7x | +293 | +13x |
- .indent_mods = .indent_mods,+ "Fit warnings occurred, please consider using a simpler model, or", |
| 205 | -7x | +294 | +13x |
- extra_args = extra_args+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
| 206 | +295 |
- )+ )) |
||
| 207 | +296 |
- # Insert label row as first row in table.+ }+ |
+ ||
| 297 | ++ |
+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
||
| 208 | -7x | +298 | +58x |
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ estimates <- t(vapply( |
| 209 | -7x | +299 | +58x |
- tab_sub+ X = x, |
| 210 | -+ | |||
| 300 | +58x |
- })+ FUN = h_step_trt_effect, |
||
| 211 | -4x | +301 | +58x |
- result <- do.call(rbind, tabs)+ FUN.VALUE = c(1, 2), |
| 212 | -+ | |||
| 302 | +58x |
-
+ data = data, |
||
| 213 | -4x | +303 | +58x |
- n_tot_ids <- grep("^n_tot", vars)
+ model = fit, |
| 214 | -4x | +304 | +58x |
- hr_id <- match("hr", vars)
+ variables = variables+ |
+
| 305 | ++ |
+ )) |
||
| 215 | -4x | +306 | +58x |
- ci_id <- match("ci", vars)
+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
| 216 | -4x | +307 | +58x |
- structure(+ cbind( |
| 217 | -4x | +308 | +58x |
- result,+ n = length(fit$y), |
| 218 | -4x | +309 | +58x |
- forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
+ logor = estimates[, "est"], |
| 219 | -4x | +310 | +58x |
- col_x = hr_id,+ se = estimates[, "se"], |
| 220 | -4x | +311 | +58x |
- col_ci = ci_id,+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
| 221 | -4x | +312 | +58x |
- col_symbol_size = n_tot_ids[1]+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
| 222 | +313 |
) |
||
| 223 | +314 |
}@@ -101020,14 +102238,14 @@ tern coverage - 90.46% |
| 1 |
- #' Control Function for Subgroup Treatment Effect Pattern (STEP) Calculations+ #' Missing Data |
||
| 5 |
- #' This is an auxiliary function for controlling arguments for STEP calculations.+ #' Substitute missing data with a string or factor level. |
||
| 7 |
- #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which+ #' @param x (`factor` or `character` vector)\cr values for which any missing values should be substituted. |
||
| 8 |
- #' could be used to infer `bandwidth`, see below.+ #' @param label (`character`)\cr string that missing data should be replaced with. |
||
| 9 |
- #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to+ #' |
||
| 10 |
- #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data+ #' @return `x` with any `NA` values substituted by `label`. |
||
| 11 |
- #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly+ #' |
||
| 12 |
- #' distributed.+ #' @examples |
||
| 13 |
- #' @param bandwidth (`number` or `NULL`)\cr indicating the bandwidth of each window.+ #' explicit_na(c(NA, "a", "b")) |
||
| 14 |
- #' Depending on the argument `use_percentile`, it can be either the length of actual-value+ #' is.na(explicit_na(c(NA, "a", "b"))) |
||
| 15 |
- #' windows on the real biomarker scale, or percentage windows.+ #' |
||
| 16 |
- #' If `use_percentile = TRUE`, it should be a number between 0 and 1.+ #' explicit_na(factor(c(NA, "a", "b"))) |
||
| 17 |
- #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted.+ #' is.na(explicit_na(factor(c(NA, "a", "b")))) |
||
| 18 |
- #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker`+ #' |
||
| 19 |
- #' variable for actual-value windows.+ #' explicit_na(sas_na(c("a", "")))
|
||
| 20 |
- #' @param degree (`count`)\cr the degree of polynomial function of the biomarker as an interaction term+ #' |
||
| 21 |
- #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable+ #' @export |
||
| 22 |
- #' is not included in the model fitted in each biomarker window.+ explicit_na <- function(x, label = "<Missing>") {
|
||
| 23 | -+ | 220x |
- #' @param num_points (`count`)\cr the number of points at which the hazard ratios are estimated. The+ checkmate::assert_string(label) |
| 24 |
- #' smallest number is 2.+ |
||
| 25 | -+ | 220x |
- #'+ if (is.factor(x)) {
|
| 26 | -+ | 128x |
- #' @return A list of components with the same names as the arguments, except `biomarker` which is+ x <- forcats::fct_na_value_to_level(x, label) |
| 27 | -+ | 128x |
- #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested.+ forcats::fct_drop(x, only = label) |
| 28 | -+ | 92x |
- #'+ } else if (is.character(x)) {
|
| 29 | -+ | 92x |
- #' @examples+ x[is.na(x)] <- label |
| 30 | -+ | 92x |
- #' # Provide biomarker values and request actual values to be used,+ x |
| 31 |
- #' # so that bandwidth is chosen from range.+ } else {
|
||
| 32 | -+ | ! |
- #' control_step(biomarker = 1:10, use_percentile = FALSE)+ stop("only factors and character vectors allowed")
|
| 33 |
- #'+ } |
||
| 34 |
- #' # Use a global model with quadratic biomarker interaction term.+ } |
||
| 35 |
- #' control_step(bandwidth = NULL, degree = 2)+ |
||
| 36 |
- #'+ #' Convert Strings to `NA` |
||
| 37 |
- #' # Reduce number of points to be used.+ #' |
||
| 38 |
- #' control_step(num_points = 10)+ #' @description `r lifecycle::badge("stable")`
|
||
| 40 |
- #' @export+ #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to |
||
| 41 |
- control_step <- function(biomarker = NULL,+ #' convert these values to `NA`s. |
||
| 42 |
- use_percentile = TRUE,+ #' |
||
| 43 |
- bandwidth,+ #' @inheritParams explicit_na |
||
| 44 |
- degree = 0L,+ #' @param empty (`logical`)\cr if `TRUE` empty strings get replaced by `NA`. |
||
| 45 |
- num_points = 39L) {
+ #' @param whitespaces (`logical`)\cr if `TRUE` then strings made from whitespaces only get replaced with `NA`. |
||
| 46 | -31x | +
- checkmate::assert_numeric(biomarker, null.ok = TRUE)+ #' |
|
| 47 | -30x | +
- checkmate::assert_flag(use_percentile)+ #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of |
|
| 48 | -30x | +
- checkmate::assert_int(num_points, lower = 2)+ #' `empty` and `whitespaces`. |
|
| 49 | -29x | +
- checkmate::assert_count(degree)+ #' |
|
| 50 |
-
+ #' @examples |
||
| 51 | -29x | +
- if (missing(bandwidth)) {
+ #' sas_na(c("1", "", " ", " ", "b"))
|
|
| 52 |
- # Infer bandwidth+ #' sas_na(factor(c("", " ", "b")))
|
||
| 53 | -21x | +
- bandwidth <- if (use_percentile) {
+ #' |
|
| 54 | -18x | +
- 0.25+ #' is.na(sas_na(c("1", "", " ", " ", "b")))
|
|
| 55 | -21x | +
- } else if (!is.null(biomarker)) {
+ #' |
|
| 56 | -3x | +
- diff(range(biomarker, na.rm = TRUE)) / 4+ #' @export |
|
| 57 |
- } else {
+ sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
|
||
| 58 | -! | +217x |
- NULL+ checkmate::assert_flag(empty) |
| 59 | -+ | 217x |
- }+ checkmate::assert_flag(whitespaces) |
| 60 |
- } else {
+
|
||
| 61 | -+ | 217x |
- # Check bandwidth+ if (is.factor(x)) {
|
| 62 | -8x | +121x |
- if (!is.null(bandwidth)) {
+ empty_levels <- levels(x) == "" |
| 63 | -5x | +11x |
- if (use_percentile) {
+ if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA |
| 64 | -4x | +
- assert_proportion_value(bandwidth)+ |
|
| 65 | -+ | 121x |
- } else {
+ ws_levels <- grepl("^\\s+$", levels(x))
|
| 66 | -1x | +! |
- checkmate::assert_scalar(bandwidth)+ if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA |
| 67 | -1x | +
- checkmate::assert_true(bandwidth > 0)+ |
|
| 68 | -+ | 121x |
- }+ x |
| 69 | -+ | 96x |
- }+ } else if (is.character(x)) {
|
| 70 | -+ | 96x |
- }+ if (empty) x[x == ""] <- NA_character_ |
| 71 | -28x | +
- list(+ |
|
| 72 | -28x | +96x |
- use_percentile = use_percentile,+ if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
|
| 73 | -28x | +
- bandwidth = bandwidth,+ |
|
| 74 | -28x | +96x |
- degree = as.integer(degree),+ x |
| 75 | -28x | +
- num_points = as.integer(num_points)+ } else {
|
|
| 76 | -+ | ! |
- )+ stop("only factors and character vectors allowed")
|
| 77 | + |
+ }+ |
+ |
| 78 | +
} |
@@ -101565,14 +102790,14 @@
| 1 |
- #' Get default statistical methods and their associated formats, labels, and indent modifiers+ #' Proportion Difference |
|||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 5 |
- #' Utility functions to get valid statistic methods for different method groups+ #' @inheritParams prop_diff_strat_nc |
|||
| 6 |
- #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers+ #' @inheritParams argument_convention |
|||
| 7 |
- #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be+ #' @param method (`string`)\cr the method used for the confidence interval estimation. |
|||
| 8 |
- #' seen in [analyze_vars()]. See notes to understand why this is experimental.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion_diff")`
|
|||
| 9 |
- #'+ #' to see available statistics for this function. |
|||
| 10 |
- #' @param stats (`character`)\cr statistical methods to get defaults for.+ #' |
|||
| 11 |
- #'+ #' @seealso [d_proportion_diff()] |
|||
| 12 |
- #' @details+ #' |
|||
| 13 |
- #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`.+ #' @name prop_diff |
|||
| 14 |
- #'+ #' @order 1 |
|||
| 15 |
- #' @note+ NULL |
|||
| 16 |
- #' These defaults are experimental because we use the names of functions to retrieve the default+ |
|||
| 17 |
- #' statistics. This should be generalized in groups of methods according to more reasonable groupings.+ #' @describeIn prop_diff Statistics function estimating the difference |
|||
| 18 |
- #'+ #' in terms of responder proportion. |
|||
| 19 |
- #' @name default_stats_formats_labels+ #' |
|||
| 20 |
- NULL+ #' @return |
|||
| 21 |
-
+ #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`. |
|||
| 22 |
- #' @describeIn default_stats_formats_labels Get statistics available for a given method+ #' |
|||
| 23 |
- #' group (analyze function).+ #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are |
|||
| 24 |
- #'+ #' not permitted. |
|||
| 25 |
- #' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function)+ #' |
|||
| 26 |
- #' to retrieve default statistics for. A character vector can be used to specify more than one statistical+ #' @examples |
|||
| 27 |
- #' method group.+ #' s_proportion_diff( |
|||
| 28 |
- #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group.+ #' df = subset(dta, grp == "A"), |
|||
| 29 |
- #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains+ #' .var = "rsp", |
|||
| 30 |
- #' `"analyze_vars_counts"`) be added to the statistical methods?+ #' .ref_group = subset(dta, grp == "B"), |
|||
| 31 |
- #'+ #' .in_ref_col = FALSE, |
|||
| 32 |
- #' @return+ #' conf_level = 0.90, |
|||
| 33 |
- #' * `get_stats()` returns a `character` vector of statistical methods.+ #' method = "ha" |
|||
| 34 |
- #'+ #' ) |
|||
| 35 |
- #' @examples+ #' |
|||
| 36 |
- #' # analyze_vars is numeric+ #' # CMH example with strata |
|||
| 37 |
- #' num_stats <- get_stats("analyze_vars_numeric") # also the default
+ #' s_proportion_diff( |
|||
| 38 |
- #'+ #' df = subset(dta, grp == "A"), |
|||
| 39 |
- #' # Other type+ #' .var = "rsp", |
|||
| 40 |
- #' cnt_stats <- get_stats("analyze_vars_counts")
+ #' .ref_group = subset(dta, grp == "B"), |
|||
| 41 |
- #'+ #' .in_ref_col = FALSE, |
|||
| 42 |
- #' # Weirdly taking the pval from count_occurrences+ #' variables = list(strata = c("f1", "f2")),
|
|||
| 43 |
- #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
+ #' conf_level = 0.90, |
|||
| 44 |
- #'+ #' method = "cmh" |
|||
| 45 |
- #' # All count_occurrences+ #' ) |
|||
| 46 |
- #' all_cnt_occ <- get_stats("count_occurrences")
+ #' |
|||
| 47 |
- #'+ #' @export |
|||
| 48 |
- #' # Multiple+ s_proportion_diff <- function(df, |
|||
| 49 |
- #' get_stats(c("count_occurrences", "analyze_vars_counts"))
+ .var, |
|||
| 50 |
- #'+ .ref_group, |
|||
| 51 |
- #' @export+ .in_ref_col, |
|||
| 52 |
- get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
+ variables = list(strata = NULL), |
|||
| 53 | -428x | +
- checkmate::assert_character(method_groups)+ conf_level = 0.95, |
||
| 54 | -428x | +
- checkmate::assert_character(stats_in, null.ok = TRUE)+ method = c( |
||
| 55 | -428x | +
- checkmate::assert_flag(add_pval)+ "waldcc", "wald", "cmh", |
||
| 56 |
-
+ "ha", "newcombe", "newcombecc", |
|||
| 57 |
- # Default is still numeric+ "strat_newcombe", "strat_newcombecc" |
|||
| 58 | -428x | +
- if (any(method_groups == "analyze_vars")) {
+ ), |
||
| 59 | -2x | +
- method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"+ weights_method = "cmh") {
|
||
| 60 | -+ | 2x |
- }+ method <- match.arg(method) |
|
| 61 | -+ | 2x |
-
+ if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
|
|
| 62 | -428x | +! |
- type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
+ stop(paste( |
|
| 63 | -+ | ! |
-
+ "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not", |
|
| 64 | -+ | ! |
- # Defaults for loop+ "permitted. Please choose a different method." |
|
| 65 | -428x | +
- out <- NULL+ )) |
||
| 66 |
-
+ } |
|||
| 67 | -+ | 2x |
- # Loop for multiple method groups+ y <- list(diff = "", diff_ci = "") |
|
| 68 | -428x | +
- for (mgi in method_groups) {
+
|
||
| 69 | -438x | +2x |
- out_tmp <- if (mgi %in% names(tern_default_stats)) {
+ if (!.in_ref_col) {
|
|
| 70 | -438x | +2x |
- tern_default_stats[[mgi]]+ rsp <- c(.ref_group[[.var]], df[[.var]]) |
|
| 71 | -+ | 2x |
- } else {
+ grp <- factor( |
|
| 72 | -! | +2x |
- stop("The selected method group (", mgi, ") has no default statistical method.")
+ rep( |
|
| 73 | -+ | 2x |
- }+ c("ref", "Not-ref"),
|
|
| 74 | -438x | +2x |
- out <- unique(c(out, out_tmp))+ c(nrow(.ref_group), nrow(df)) |
|
| 75 |
- }+ ), |
|||
| 76 | -+ | 2x |
-
+ levels = c("ref", "Not-ref")
|
|
| 77 |
- # If you added pval to the stats_in you certainly want it+ ) |
|||
| 78 | -428x | +
- if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
+
|
||
| 79 | -24x | +2x |
- stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
+ if (!is.null(variables$strata)) {
|
|
| 80 | -+ | 1x |
-
+ strata_colnames <- variables$strata |
|
| 81 | -+ | 1x |
- # Must be only one value between choices+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
|
| 82 | -24x | +1x |
- checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
|
| 84 | -+ | 1x |
- # Mismatch with counts and numeric+ assert_df_with_variables(df, strata_vars) |
|
| 85 | -23x | +1x |
- if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
+ assert_df_with_variables(.ref_group, strata_vars) |
|
| 86 | -23x | +
- any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
+
|
||
| 87 | -2x | +
- stop(+ # Merging interaction strata for reference group rows data and remaining |
||
| 88 | -2x | +1x |
- "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
+ strata <- c( |
|
| 89 | -2x | +1x |
- type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),+ interaction(.ref_group[strata_colnames]), |
|
| 90 | -2x | +1x |
- " instead."+ interaction(df[strata_colnames]) |
|
| 92 | -+ | 1x |
- }+ strata <- as.factor(strata) |
|
| 93 |
-
+ } |
|||
| 94 |
- # Lets add it even if present (thanks to unique)+ |
|||
| 95 | -21x | +
- add_pval <- TRUE+ # Defining the std way to calculate weights for strat_newcombe |
||
| 96 | -+ | 2x |
- }+ if (!is.null(variables$weights_method)) {
|
|
| 97 | -+ | ! |
-
+ weights_method <- variables$weights_method |
|
| 98 |
- # Mainly used in "analyze_vars" but it could be necessary elsewhere+ } else {
|
|||
| 99 | -425x | +2x |
- if (isTRUE(add_pval)) {
+ weights_method <- "cmh" |
|
| 100 | -25x | +
- if (any(grepl("counts", method_groups))) {
+ } |
||
| 101 | -10x | +
- out <- unique(c(out, "pval_counts"))+ |
||
| 102 | -+ | 2x |
- } else {
+ y <- switch(method, |
|
| 103 | -15x | +2x |
- out <- unique(c(out, "pval"))+ "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE), |
|
| 104 | -+ | 2x |
- }+ "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE), |
|
| 105 | -+ | 2x |
- }+ "ha" = prop_diff_ha(rsp, grp, conf_level), |
|
| 106 | -+ | 2x |
-
+ "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE), |
|
| 107 | -+ | 2x |
- # Filtering for stats_in (character vector)+ "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE), |
|
| 108 | -425x | +2x |
- if (!is.null(stats_in)) {
+ "strat_newcombe" = prop_diff_strat_nc(rsp, |
|
| 109 | -396x | +2x |
- out <- intersect(stats_in, out) # It orders them too+ grp, |
|
| 110 | -+ | 2x |
- }+ strata, |
|
| 111 | -+ | 2x |
-
+ weights_method, |
|
| 112 | -+ | 2x |
- # If intersect did not find matches (and no pval?) -> error+ conf_level, |
|
| 113 | -425x | +2x |
- if (length(out) == 0) {
+ correct = FALSE |
|
| 114 | -2x | +
- stop(+ ), |
||
| 115 | 2x |
- "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
+ "strat_newcombecc" = prop_diff_strat_nc(rsp, |
||
| 116 | 2x |
- " do not have the required default statistical methods:\n",+ grp, |
||
| 117 | 2x |
- paste0(stats_in, collapse = " ")+ strata, |
||
| 118 | -+ | 2x |
- )+ weights_method, |
|
| 119 | -+ | 2x |
- }+ conf_level, |
|
| 120 | -+ | 2x |
-
+ correct = TRUE |
|
| 121 | -423x | +
- out+ ), |
||
| 122 | -+ | 2x |
- }+ "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
|
|
| 123 |
-
+ ) |
|||
| 124 |
- #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics.+ |
|||
| 125 | -+ | 2x |
- #'+ y$diff <- y$diff * 100 |
|
| 126 | -+ | 2x |
- #' @param formats_in (named `vector`) \cr inserted formats to replace defaults. It can be a+ y$diff_ci <- y$diff_ci * 100 |
|
| 127 |
- #' character vector from [formatters::list_valid_format_labels()] or a custom format function.+ } |
|||
| 128 |
- #'+ |
|||
| 129 | -+ | 2x |
- #' @return+ attr(y$diff, "label") <- "Difference in Response rate (%)" |
|
| 130 | -+ | 2x |
- #' * `get_formats_from_stats()` returns a named vector of formats (if present in either+ attr(y$diff_ci, "label") <- d_proportion_diff( |
|
| 131 | -+ | 2x |
- #' `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from+ conf_level, method, |
|
| 132 | -+ | 2x |
- #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]).+ long = FALSE |
|
| 133 |
- #'+ ) |
|||
| 134 |
- #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and+ |
|||
| 135 | -+ | 2x |
- #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
+ y |
|
| 136 |
- #'+ } |
|||
| 137 |
- #' @examples+ |
|||
| 138 |
- #' # Defaults formats+ #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`. |
|||
| 139 |
- #' get_formats_from_stats(num_stats)+ #' |
|||
| 140 |
- #' get_formats_from_stats(cnt_stats)+ #' @return |
|||
| 141 |
- #' get_formats_from_stats(only_pval)+ #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 142 |
- #' get_formats_from_stats(all_cnt_occ)+ #' |
|||
| 143 |
- #'+ #' @examples |
|||
| 144 |
- #' # Addition of customs+ #' a_proportion_diff( |
|||
| 145 |
- #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
+ #' df = subset(dta, grp == "A"), |
|||
| 146 |
- #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
+ #' .var = "rsp", |
|||
| 147 |
- #'+ #' .ref_group = subset(dta, grp == "B"), |
|||
| 148 |
- #' @seealso [formatting_functions]+ #' .in_ref_col = FALSE, |
|||
| 149 |
- #'+ #' conf_level = 0.90, |
|||
| 150 |
- #' @export+ #' method = "ha" |
|||
| 151 |
- get_formats_from_stats <- function(stats, formats_in = NULL) {
+ #' ) |
|||
| 152 | -416x | +
- checkmate::assert_character(stats, min.len = 1)+ #' |
||
| 153 |
- # It may be a list if there is a function in the formats+ #' @export |
|||
| 154 | -416x | +
- if (checkmate::test_list(formats_in, null.ok = TRUE)) {
+ a_proportion_diff <- make_afun( |
||
| 155 | -357x | +
- checkmate::assert_list(formats_in, null.ok = TRUE)+ s_proportion_diff, |
||
| 156 |
- # Or it may be a vector of characters+ .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), |
|||
| 157 |
- } else {
+ .indent_mods = c(diff = 0L, diff_ci = 1L) |
|||
| 158 | -59x | +
- checkmate::assert_character(formats_in, null.ok = TRUE)+ ) |
||
| 159 |
- }+ |
|||
| 160 |
-
+ #' @describeIn prop_diff Layout-creating function which can take statistics function arguments |
|||
| 161 |
- # Extract global defaults+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 162 | -416x | +
- which_fmt <- match(stats, names(tern_default_formats))+ #' |
||
| 163 |
-
+ #' @return |
|||
| 164 |
- # Select only needed formats from stats+ #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
|||
| 165 | -416x | +
- ret <- vector("list", length = length(stats)) # Returning a list is simpler
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 166 | -416x | +
- ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]]+ #' the statistics from `s_proportion_diff()` to the table layout. |
||
| 167 |
-
+ #' |
|||
| 168 | -416x | +
- out <- setNames(ret, stats)+ #' @examples |
||
| 169 |
-
+ #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B. |
|||
| 170 |
- # Modify some with custom formats+ #' nex <- 100 # Number of example rows |
|||
| 171 | -416x | +
- if (!is.null(formats_in)) {
+ #' dta <- data.frame( |
||
| 172 |
- # Stats is the main+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
|||
| 173 | -61x | +
- common_names <- intersect(names(out), names(formats_in))+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
||
| 174 | -61x | +
- out[common_names] <- formats_in[common_names]+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 175 |
- }+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
|||
| 176 |
-
+ #' stringsAsFactors = TRUE |
|||
| 177 | -416x | +
- out+ #' ) |
||
| 178 |
- }+ #' |
|||
| 179 |
-
+ #' l <- basic_table() %>% |
|||
| 180 |
- #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics.+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
|||
| 181 |
- #'+ #' estimate_proportion_diff( |
|||
| 182 |
- #' @param labels_in (named `vector` of `character`)\cr inserted labels to replace defaults.+ #' vars = "rsp", |
|||
| 183 |
- #' @param row_nms (`character`)\cr row names. Levels of a `factor` or `character` variable, each+ #' conf_level = 0.90, |
|||
| 184 |
- #' of which the statistics in `.stats` will be calculated for. If this parameter is set, these+ #' method = "ha" |
|||
| 185 |
- #' variable levels will be used as the defaults, and the names of the given custom values should+ #' ) |
|||
| 186 |
- #' correspond to levels (or have format `statistic.level`) instead of statistics. Can also be+ #' |
|||
| 187 |
- #' variable names if rows correspond to different variables instead of levels. Defaults to `NULL`.+ #' build_table(l, df = dta) |
|||
| 189 |
- #' @return+ #' @export |
|||
| 190 |
- #' * `get_labels_from_stats()` returns a named `character` vector of labels (if present in either+ #' @order 2 |
|||
| 191 |
- #' `tern_default_labels` or `labels_in`, otherwise `NULL`).+ estimate_proportion_diff <- function(lyt, |
|||
| 192 |
- #'+ vars, |
|||
| 193 |
- #' @examples+ variables = list(strata = NULL), |
|||
| 194 |
- #' # Defaults labels+ conf_level = 0.95, |
|||
| 195 |
- #' get_labels_from_stats(num_stats)+ method = c( |
|||
| 196 |
- #' get_labels_from_stats(cnt_stats)+ "waldcc", "wald", "cmh", |
|||
| 197 |
- #' get_labels_from_stats(only_pval)+ "ha", "newcombe", "newcombecc", |
|||
| 198 |
- #' get_labels_from_stats(all_cnt_occ)+ "strat_newcombe", "strat_newcombecc" |
|||
| 199 |
- #'+ ), |
|||
| 200 |
- #' # Addition of customs+ weights_method = "cmh", |
|||
| 201 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
+ na_str = default_na_str(), |
|||
| 202 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
+ nested = TRUE, |
|||
| 203 |
- #'+ ..., |
|||
| 204 |
- #' @export+ var_labels = vars, |
|||
| 205 |
- get_labels_from_stats <- function(stats, labels_in = NULL, row_nms = NULL) {
+ show_labels = "hidden", |
|||
| 206 | -401x | +
- checkmate::assert_character(stats, min.len = 1)+ table_names = vars, |
||
| 207 | -401x | +
- checkmate::assert_character(row_nms, null.ok = TRUE)+ .stats = NULL, |
||
| 208 |
- # It may be a list+ .formats = NULL, |
|||
| 209 | -401x | +
- if (checkmate::test_list(labels_in, null.ok = TRUE)) {
+ .labels = NULL, |
||
| 210 | -334x | +
- checkmate::assert_list(labels_in, null.ok = TRUE)+ .indent_mods = NULL) {
|
||
| 211 | -+ | 4x |
- # Or it may be a vector of characters+ extra_args <- list( |
|
| 212 | -+ | 4x |
- } else {
+ variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ... |
|
| 213 | -67x | +
- checkmate::assert_character(labels_in, null.ok = TRUE)+ ) |
||
| 214 |
- }+ |
|||
| 215 | -+ | 4x |
-
+ afun <- make_afun( |
|
| 216 | -401x | +4x |
- if (!is.null(row_nms)) {
+ a_proportion_diff, |
|
| 217 | -43x | +4x |
- ret <- rep(row_nms, length(stats))+ .stats = .stats, |
|
| 218 | -43x | +4x |
- out <- setNames(ret, paste(rep(stats, each = length(row_nms)), ret, sep = "."))+ .formats = .formats, |
|
| 219 | -+ | 4x |
-
+ .labels = .labels, |
|
| 220 | -43x | +4x |
- if (!is.null(labels_in)) {
+ .indent_mods = .indent_mods |
|
| 221 | -1x | +
- lvl_lbls <- intersect(names(labels_in), row_nms)+ ) |
||
| 222 | -1x | +
- for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- labels_in[[i]]+ |
||
| 223 | -+ | 4x |
- }+ analyze( |
|
| 224 | -+ | 4x |
- } else {
+ lyt, |
|
| 225 | -358x | +4x |
- which_lbl <- match(stats, names(tern_default_labels))+ vars, |
|
| 226 | -+ | 4x |
-
+ afun = afun, |
|
| 227 | -358x | +4x |
- ret <- vector("character", length = length(stats)) # it needs to be a character vector
+ var_labels = var_labels, |
|
| 228 | -358x | +4x |
- ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]]+ na_str = na_str, |
|
| 229 | -+ | 4x |
-
+ nested = nested, |
|
| 230 | -358x | +4x |
- out <- setNames(ret, stats)+ extra_args = extra_args, |
|
| 231 | -+ | 4x |
- }+ show_labels = show_labels, |
|
| 232 | -+ | 4x |
-
+ table_names = table_names |
|
| 233 |
- # Modify some with custom labels+ ) |
|||
| 234 | -401x | +
- if (!is.null(labels_in)) {
+ } |
||
| 235 |
- # Stats is the main+ |
|||
| 236 | -67x | +
- common_names <- intersect(names(out), names(labels_in))+ #' Check: Proportion Difference Arguments |
||
| 237 | -67x | +
- out[common_names] <- labels_in[common_names]+ #' |
||
| 238 |
- }+ #' Verifies that and/or convert arguments into valid values to be used in the |
|||
| 239 |
-
+ #' estimation of difference in responder proportions. |
|||
| 240 | -401x | +
- out+ #' |
||
| 241 |
- }+ #' @inheritParams prop_diff |
|||
| 242 |
-
+ #' @inheritParams prop_diff_wald |
|||
| 243 |
- #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics.+ #' |
|||
| 244 |
- #'+ #' @keywords internal |
|||
| 245 |
- #' @param indents_in (named `vector`)\cr inserted indent modifiers to replace defaults (default is `0L`).+ check_diff_prop_ci <- function(rsp, |
|||
| 246 |
- #'+ grp, |
|||
| 247 |
- #' @return+ strata = NULL, |
|||
| 248 |
- #' * `get_indents_from_stats()` returns a single indent modifier value to apply to all rows+ conf_level, |
|||
| 249 |
- #' or a named numeric vector of indent modifiers (if present, otherwise `NULL`).+ correct = NULL) {
|
|||
| 250 | -+ | 19x |
- #'+ checkmate::assert_logical(rsp, any.missing = FALSE) |
|
| 251 | -+ | 19x |
- #' @examples+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
|
| 252 | -+ | 19x |
- #' get_indents_from_stats(all_cnt_occ, indents_in = 3L)+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
|
| 253 | -+ | 19x |
- #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L))+ checkmate::assert_flag(correct, null.ok = TRUE) |
|
| 254 |
- #' get_indents_from_stats(+ |
|||
| 255 | -+ | 19x |
- #' all_cnt_occ,+ if (!is.null(strata)) {
|
|
| 256 | -+ | 11x |
- #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L), row_nms = c("a", "b")
+ checkmate::assert_factor(strata, len = length(rsp)) |
|
| 257 |
- #' )+ } |
|||
| 258 |
- #'+ |
|||
| 259 | -+ | 19x |
- #' @export+ invisible() |
|
| 260 |
- get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
+ } |
|||
| 261 | -386x | +
- checkmate::assert_character(stats, min.len = 1)+ |
||
| 262 | -386x | +
- checkmate::assert_character(row_nms, null.ok = TRUE)+ #' Description of Method Used for Proportion Comparison |
||
| 263 |
- # It may be a list+ #' |
|||
| 264 | -386x | +
- if (checkmate::test_list(indents_in, null.ok = TRUE)) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 265 | -337x | +
- checkmate::assert_list(indents_in, null.ok = TRUE)+ #' |
||
| 266 |
- # Or it may be a vector of integers+ #' This is an auxiliary function that describes the analysis in |
|||
| 267 |
- } else {
+ #' `s_proportion_diff`. |
|||
| 268 | -49x | +
- checkmate::assert_integerish(indents_in, null.ok = TRUE)+ #' |
||
| 269 |
- }+ #' @inheritParams s_proportion_diff |
|||
| 270 |
-
+ #' @param long (`logical`)\cr Whether a long or a short (default) description is required. |
|||
| 271 | -386x | +
- if (is.null(names(indents_in)) && length(indents_in) == 1) {
+ #' |
||
| 272 | -8x | +
- out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1)+ #' @return A `string` describing the analysis. |
||
| 273 | -8x | +
- return(out)+ #' |
||
| 274 |
- }+ #' @seealso [prop_diff] |
|||
| 275 |
-
+ #' |
|||
| 276 | -378x | +
- if (!is.null(row_nms)) {
+ #' @export |
||
| 277 | -37x | +
- ret <- rep(0L, length(stats) * length(row_nms))+ d_proportion_diff <- function(conf_level, |
||
| 278 | -37x | +
- out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = "."))+ method, |
||
| 279 |
-
+ long = FALSE) {
|
|||
| 280 | -37x | +11x |
- if (!is.null(indents_in)) {
+ label <- paste0(conf_level * 100, "% CI") |
|
| 281 | -1x | +11x |
- lvl_lbls <- intersect(names(indents_in), row_nms)+ if (long) {
|
|
| 282 | -1x | +! |
- for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]]+ label <- paste( |
|
| 283 | -+ | ! |
- }+ label, |
|
| 284 | -+ | ! |
- } else {
+ ifelse( |
|
| 285 | -341x | +! |
- ret <- rep(0L, length(stats))+ method == "cmh", |
|
| 286 | -341x | +! |
- out <- setNames(ret, stats)+ "for adjusted difference", |
|
| 287 | -+ | ! |
- }+ "for difference" |
|
| 288 |
-
+ ) |
|||
| 289 |
- # Modify some with custom labels+ ) |
|||
| 290 | -378x | +
- if (!is.null(indents_in)) {
+ } |
||
| 291 |
- # Stats is the main+ |
|||
| 292 | -42x | +11x |
- common_names <- intersect(names(out), names(indents_in))+ method_part <- switch(method, |
|
| 293 | -42x | +11x |
- out[common_names] <- indents_in[common_names]+ "cmh" = "CMH, without correction", |
|
| 294 | -+ | 11x |
- }+ "waldcc" = "Wald, with correction", |
|
| 295 | -+ | 11x |
-
+ "wald" = "Wald, without correction", |
|
| 296 | -378x | +11x |
- out+ "ha" = "Anderson-Hauck", |
|
| 297 | -+ | 11x |
- }+ "newcombe" = "Newcombe, without correction", |
|
| 298 | -+ | 11x |
-
+ "newcombecc" = "Newcombe, with correction", |
|
| 299 | -+ | 11x |
- #' Update Labels According to Control Specifications+ "strat_newcombe" = "Stratified Newcombe, without correction", |
|
| 300 | -+ | 11x |
- #'+ "strat_newcombecc" = "Stratified Newcombe, with correction", |
|
| 301 | -+ | 11x |
- #' @description `r lifecycle::badge("stable")`
+ stop(paste(method, "does not have a description")) |
|
| 302 |
- #'+ ) |
|||
| 303 | -+ | 11x |
- #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant+ paste0(label, " (", method_part, ")")
|
|
| 304 |
- #' control specification. For example, if control has element `conf_level` set to `0.9`, the default+ } |
|||
| 305 |
- #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied+ |
|||
| 306 |
- #' via `labels_custom` will not be updated regardless of `control`.+ #' Helper Functions to Calculate Proportion Difference |
|||
| 308 |
- #' @param labels_default (named `vector` of `character`)\cr a named vector of statistic labels to modify+ #' @description `r lifecycle::badge("stable")`
|
|||
| 309 |
- #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will+ #' |
|||
| 310 |
- #' not be affected.+ #' @inheritParams argument_convention |
|||
| 311 |
- #' @param labels_custom (named `vector` of `character`)\cr named vector of labels that are customized by+ #' @inheritParams prop_diff |
|||
| 312 |
- #' the user and should not be affected by `control`.+ #' @param grp (`factor`)\cr vector assigning observations to one out of two groups |
|||
| 313 |
- #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels.+ #' (e.g. reference and treatment group). |
|||
| 315 |
- #' @return A named character vector of labels with control specifications applied to relevant labels.+ #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci` |
|||
| 316 |
- #'+ #' (proportion difference confidence interval). |
|||
| 317 |
- #' @examples+ #' |
|||
| 318 |
- #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57)+ #' @seealso [prop_diff()] for implementation of these helper functions. |
|||
| 319 |
- #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
+ #' |
|||
| 320 |
- #' labels_use_control(control = control)+ #' @name h_prop_diff |
|||
| 321 |
- #'+ NULL |
|||
| 322 |
- #' @export+ |
|||
| 323 |
- labels_use_control <- function(labels_default, control, labels_custom = NULL) {
+ #' @describeIn h_prop_diff The Wald interval follows the usual textbook |
|||
| 324 | -14x | +
- if ("conf_level" %in% names(control)) {
+ #' definition for a single proportion confidence interval using the normal |
||
| 325 | -14x | +
- labels_default <- sapply(+ #' approximation. It is possible to include a continuity correction for Wald's |
||
| 326 | -14x | +
- names(labels_default),+ #' interval. |
||
| 327 | -14x | +
- function(x) {
+ #' |
||
| 328 | -65x | +
- if (!x %in% names(labels_custom)) {
+ #' @param correct (`logical`)\cr whether to include the continuity correction. For further |
||
| 329 | -64x | +
- gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]]))+ #' information, see [stats::prop.test()]. |
||
| 330 |
- } else {
+ #' |
|||
| 331 | -1x | +
- labels_default[[x]]+ #' @examples |
||
| 332 |
- }+ #' # Wald confidence interval |
|||
| 333 |
- }+ #' set.seed(2) |
|||
| 334 |
- )+ #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20) |
|||
| 335 |
- }+ #' grp <- factor(c(rep("A", 10), rep("B", 10)))
|
|||
| 336 | -14x | +
- if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
+ #' |
||
| 337 | -14x | +
- !"quantiles" %in% names(labels_custom)) { # nolint
+ #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE) |
||
| 338 | -14x | +
- labels_default["quantiles"] <- gsub(+ #' |
||
| 339 | -14x | +
- "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""),+ #' @export |
||
| 340 | -14x | +
- labels_default["quantiles"]+ prop_diff_wald <- function(rsp, |
||
| 341 |
- )+ grp, |
|||
| 342 |
- }+ conf_level = 0.95, |
|||
| 343 | -14x | +
- if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
+ correct = FALSE) {
|
||
| 344 | -14x | +4x |
- !"mean_pval" %in% names(labels_custom)) { # nolint
+ if (isTRUE(correct)) {
|
|
| 345 | -1x | +3x |
- labels_default["mean_pval"] <- gsub(+ mthd <- "waldcc" |
|
| 346 | -1x | +
- "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"]+ } else {
|
||
| 347 | -+ | 1x |
- )+ mthd <- "wald" |
|
| 349 | -+ | 4x |
-
+ grp <- as_factor_keep_attributes(grp) |
|
| 350 | -14x | +4x |
- labels_default+ check_diff_prop_ci( |
|
| 351 | -+ | 4x |
- }+ rsp = rsp, grp = grp, conf_level = conf_level, correct = correct |
|
| 352 |
-
+ ) |
|||
| 353 |
- #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`.+ |
|||
| 354 |
- #'+ # check if binary response is coded as logical |
|||
| 355 | -+ | 4x |
- #' @format+ checkmate::assert_logical(rsp, any.missing = FALSE) |
|
| 356 | -+ | 4x |
- #' * `tern_default_stats` is a named list of available statistics, with each element+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
|
| 357 |
- #' named for their corresponding statistical method group.+ |
|||
| 358 | -+ | 4x |
- #'+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
|
| 359 |
- #' @export+ # x1 and n1 are non-reference groups. |
|||
| 360 | -+ | 4x |
- tern_default_stats <- list(+ diff_ci <- desctools_binom( |
|
| 361 | -+ | 4x |
- abnormal = c("fraction"),
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
|
| 362 | -+ | 4x |
- abnormal_by_baseline = c("fraction"),
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
|
| 363 | -+ | 4x |
- abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
+ conf.level = conf_level, |
|
| 364 | -+ | 4x |
- abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ method = mthd |
|
| 365 |
- abnormal_by_worst_grade_worsen = c("fraction"),
+ ) |
|||
| 366 |
- analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
+
|
|||
| 367 | -+ | 4x |
- analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ list( |
|
| 368 | -+ | 4x |
- analyze_vars_numeric = c(+ "diff" = unname(diff_ci[, "est"]), |
|
| 369 | -+ | 4x |
- "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval",+ "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
|
|
| 370 |
- "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv",+ ) |
|||
| 371 |
- "geom_mean", "geom_mean_ci", "geom_cv"+ } |
|||
| 372 |
- ),+ |
|||
| 373 |
- count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
+ #' @describeIn h_prop_diff Anderson-Hauck confidence interval. |
|||
| 374 |
- count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
+ #' |
|||
| 375 |
- count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
+ #' @examples |
|||
| 376 |
- count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ #' # Anderson-Hauck confidence interval |
|||
| 377 |
- count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B. |
|||
| 378 |
- count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE) |
|||
| 379 |
- count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
|
|||
| 380 |
- coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
+ #' |
|||
| 381 |
- estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci"),
+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90) |
|||
| 382 |
- estimate_multinomial_response = c("n_prop", "prop_ci"),
+ #' |
|||
| 383 |
- estimate_odds_ratio = c("or_ci", "n_tot"),
+ #' ## Edge case: Same proportion of response in A and B. |
|||
| 384 |
- estimate_proportion = c("n_prop", "prop_ci"),
+ #' rsp <- c(TRUE, FALSE, TRUE, FALSE) |
|||
| 385 |
- estimate_proportion_diff = c("diff", "diff_ci"),
+ #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
|||
| 386 |
- summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
+ #' |
|||
| 387 |
- summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6) |
|||
| 388 |
- summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ #' |
|||
| 389 |
- summarize_num_patients = c("unique", "nonunique", "unique_count"),
+ #' @export |
|||
| 390 |
- summarize_patients_events_in_cols = c("unique", "all"),
+ prop_diff_ha <- function(rsp, |
|||
| 391 |
- surv_time = c("median", "median_ci", "quantiles", "range_censor", "range_event", "range"),
+ grp, |
|||
| 392 |
- surv_timepoint = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval"),
+ conf_level) {
|
|||
| 393 | -+ | 3x |
- tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ grp <- as_factor_keep_attributes(grp) |
|
| 394 | -+ | 3x |
- tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
|
| 395 |
- tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+
|
|||
| 396 | -+ | 3x |
- tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
|
| 397 |
- test_proportion_diff = c("pval")
+ # x1 and n1 are non-reference groups. |
|||
| 398 | -+ | 3x |
- )+ ci <- desctools_binom( |
|
| 399 | -+ | 3x |
-
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
|
| 400 | -+ | 3x |
- #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`.+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
|
| 401 | -+ | 3x |
- #'+ conf.level = conf_level, |
|
| 402 | -+ | 3x |
- #' @format+ method = "ha" |
|
| 403 |
- #' * `tern_default_formats` is a named vector of available default formats, with each element+ ) |
|||
| 404 | -+ | 3x |
- #' named for their corresponding statistic.+ list( |
|
| 405 | -+ | 3x |
- #'+ "diff" = unname(ci[, "est"]), |
|
| 406 | -+ | 3x |
- #' @export+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
|
| 407 |
- tern_default_formats <- c(+ ) |
|||
| 408 |
- fraction = format_fraction_fixed_dp,+ } |
|||
| 409 |
- unique = format_count_fraction_fixed_dp,+ |
|||
| 410 |
- nonunique = "xx",+ #' @describeIn h_prop_diff `Newcombe` confidence interval. It is based on |
|||
| 411 |
- unique_count = "xx",+ #' the Wilson score confidence interval for a single binomial proportion. |
|||
| 412 |
- n = "xx.",+ #' |
|||
| 413 |
- count = "xx.",+ #' @examples |
|||
| 414 |
- count_fraction = format_count_fraction,+ #' # `Newcombe` confidence interval |
|||
| 415 |
- count_fraction_fixed_dp = format_count_fraction_fixed_dp,+ #' |
|||
| 416 |
- n_blq = "xx.",+ #' set.seed(1) |
|||
| 417 |
- sum = "xx.x",+ #' rsp <- c( |
|||
| 418 |
- mean = "xx.x",+ #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE), |
|||
| 419 |
- sd = "xx.x",+ #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE) |
|||
| 420 |
- se = "xx.x",+ #' ) |
|||
| 421 |
- mean_sd = "xx.x (xx.x)",+ #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
|
|||
| 422 |
- mean_se = "xx.x (xx.x)",+ #' table(rsp, grp) |
|||
| 423 |
- mean_ci = "(xx.xx, xx.xx)",+ #' |
|||
| 424 |
- mean_sei = "(xx.xx, xx.xx)",+ #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9) |
|||
| 425 |
- mean_sdi = "(xx.xx, xx.xx)",+ #' |
|||
| 426 |
- mean_pval = "xx.xx",+ #' @export |
|||
| 427 |
- median = "xx.x",+ prop_diff_nc <- function(rsp, |
|||
| 428 |
- mad = "xx.x",+ grp, |
|||
| 429 |
- median_ci = "(xx.xx, xx.xx)",+ conf_level, |
|||
| 430 |
- quantiles = "xx.x - xx.x",+ correct = FALSE) {
|
|||
| 431 | -+ | 1x |
- iqr = "xx.x",+ if (isTRUE(correct)) {
|
|
| 432 | -+ | ! |
- range = "xx.x - xx.x",+ mthd <- "scorecc" |
|
| 433 |
- min = "xx.x",+ } else {
|
|||
| 434 | -+ | 1x |
- max = "xx.x",+ mthd <- "score" |
|
| 435 |
- median_range = "xx.x (xx.x - xx.x)",+ } |
|||
| 436 | -+ | 1x |
- cv = "xx.x",+ grp <- as_factor_keep_attributes(grp) |
|
| 437 | -+ | 1x |
- geom_mean = "xx.x",+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
|
| 438 |
- geom_mean_ci = "(xx.xx, xx.xx)",+ |
|||
| 439 | -+ | 1x |
- geom_cv = "xx.x",+ p_grp <- tapply(rsp, grp, mean) |
|
| 440 | -+ | 1x |
- pval = "x.xxxx | (<0.0001)",+ diff_p <- unname(diff(p_grp)) |
|
| 441 | -+ | 1x |
- pval_counts = "x.xxxx | (<0.0001)",+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
|
| 442 | -+ | 1x |
- range_censor = "xx.x to xx.x",+ ci <- desctools_binom( |
|
| 443 |
- range_event = "xx.x to xx.x"+ # x1 and n1 are non-reference groups. |
|||
| 444 | -+ | 1x |
- )+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
|
| 445 | -+ | 1x |
-
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
|
| 446 | -+ | 1x |
- #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`.+ conf.level = conf_level, |
|
| 447 | -+ | 1x |
- #'+ method = mthd |
|
| 448 |
- #' @format+ ) |
|||
| 449 | -+ | 1x |
- #' * `tern_default_labels` is a named `character` vector of available default labels, with each element+ list( |
|
| 450 | -+ | 1x |
- #' named for their corresponding statistic.+ "diff" = unname(ci[, "est"]), |
|
| 451 | -+ | 1x |
- #'+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
|
| 452 |
- #' @export+ ) |
|||
| 453 |
- tern_default_labels <- c(+ } |
|||
| 454 |
- fraction = "fraction",+ |
|||
| 455 |
- unique = "Number of patients with at least one event",+ #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in |
|||
| 456 |
- nonunique = "Number of events",+ #' response rates between the experimental treatment group and the control treatment group, adjusted |
|||
| 457 |
- n = "n",+ #' for stratification factors by applying `Cochran-Mantel-Haenszel` (`CMH`) weights. For the `CMH` chi-squared |
|||
| 458 |
- count = "count",+ #' test, use [stats::mantelhaen.test()]. |
|||
| 459 |
- count_fraction = "count_fraction",+ #' |
|||
| 460 |
- count_fraction_fixed_dp = "count_fraction",+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
|||
| 461 |
- n_blq = "n_blq",+ #' |
|||
| 462 |
- sum = "Sum",+ #' @examples |
|||
| 463 |
- mean = "Mean",+ #' # Cochran-Mantel-Haenszel confidence interval |
|||
| 464 |
- sd = "SD",+ #' |
|||
| 465 |
- se = "SE",+ #' set.seed(2) |
|||
| 466 |
- mean_sd = "Mean (SD)",+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
|||
| 467 |
- mean_se = "Mean (SE)",+ #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
|
|||
| 468 |
- mean_ci = "Mean 95% CI",+ #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
|
|||
| 469 |
- mean_sei = "Mean -/+ 1xSE",+ #' strata_data <- data.frame( |
|||
| 470 |
- mean_sdi = "Mean -/+ 1xSD",+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
|||
| 471 |
- mean_pval = "Mean p-value (H0: mean = 0)",+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 472 |
- median = "Median",+ #' stringsAsFactors = TRUE |
|||
| 473 |
- mad = "Median Absolute Deviation",+ #' ) |
|||
| 474 |
- median_ci = "Median 95% CI",+ #' |
|||
| 475 |
- quantiles = "25% and 75%-ile",+ #' prop_diff_cmh( |
|||
| 476 |
- iqr = "IQR",+ #' rsp = rsp, grp = grp, strata = interaction(strata_data), |
|||
| 477 |
- range = "Min - Max",+ #' conf_level = 0.90 |
|||
| 478 |
- min = "Minimum",+ #' ) |
|||
| 479 |
- max = "Maximum",+ #' |
|||
| 480 |
- median_range = "Median (Min - Max)",+ #' @export |
|||
| 481 |
- cv = "CV (%)",+ prop_diff_cmh <- function(rsp, |
|||
| 482 |
- geom_mean = "Geometric Mean",+ grp, |
|||
| 483 |
- geom_mean_ci = "Geometric Mean 95% CI",+ strata, |
|||
| 484 |
- geom_cv = "CV % Geometric Mean",+ conf_level = 0.95) {
|
|||
| 485 | -+ | 7x |
- pval = "p-value (t-test)", # Default for numeric+ grp <- as_factor_keep_attributes(grp) |
|
| 486 | -+ | 7x |
- pval_counts = "p-value (chi-squared test)" # Default for counts+ strata <- as_factor_keep_attributes(strata) |
|
| 487 | -+ | 7x |
- )+ check_diff_prop_ci( |
|
| 488 | -+ | 7x |
-
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
|
| 489 |
- # To deprecate ---------+ ) |
|||
| 491 | -+ | 7x |
- #' @describeIn default_stats_formats_labels Quick function to retrieve default formats for summary statistics:+ if (any(tapply(rsp, strata, length) < 5)) {
|
|
| 492 | -+ | ! |
- #' [analyze_vars()] and [analyze_vars_in_cols()] principally.+ warning("Less than 5 observations in some strata.")
|
|
| 493 |
- #'+ } |
|||
| 494 |
- #' @param type (`flag`)\cr is it going to be `"numeric"` or `"counts"`?+ |
|||
| 495 |
- #'+ # first dimension: FALSE, TRUE |
|||
| 496 |
- #' @return+ # 2nd dimension: CONTROL, TX |
|||
| 497 |
- #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type.+ # 3rd dimension: levels of strata |
|||
| 498 |
- #'+ # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records |
|||
| 499 | -+ | 7x |
- #' @examples+ t_tbl <- table( |
|
| 500 | -+ | 7x |
- #' summary_formats()+ factor(rsp, levels = c("FALSE", "TRUE")),
|
|
| 501 | -+ | 7x |
- #' summary_formats(type = "counts", include_pval = TRUE)+ grp, |
|
| 502 | -+ | 7x |
- #'+ strata |
|
| 503 |
- #' @export+ ) |
|||
| 504 | -+ | 7x |
- summary_formats <- function(type = "numeric", include_pval = FALSE) {
+ n1 <- colSums(t_tbl[1:2, 1, ]) |
|
| 505 | -3x | +7x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ n2 <- colSums(t_tbl[1:2, 2, ]) |
|
| 506 | -3x | +7x |
- get_formats_from_stats(get_stats(met_grp, add_pval = include_pval))+ p1 <- t_tbl[2, 1, ] / n1 |
|
| 507 | -+ | 7x |
- }+ p2 <- t_tbl[2, 2, ] / n2 |
|
| 508 | + |
+ # CMH weights+ |
+ ||
| 509 | +7x | +
+ use_stratum <- (n1 > 0) & (n2 > 0)+ |
+ ||
| 510 | +7x | +
+ n1 <- n1[use_stratum]+ |
+ ||
| 511 | +7x | +
+ n2 <- n2[use_stratum]+ |
+ ||
| 512 | +7x | +
+ p1 <- p1[use_stratum]+ |
+ ||
| 513 | +7x | +
+ p2 <- p2[use_stratum]+ |
+ ||
| 514 | +7x | +
+ wt <- (n1 * n2 / (n1 + n2))+ |
+ ||
| 515 | +7x | +
+ wt_normalized <- wt / sum(wt)+ |
+ ||
| 516 | +7x | +
+ est1 <- sum(wt_normalized * p1)+ |
+ ||
| 517 | +7x | +
+ est2 <- sum(wt_normalized * p2)+ |
+ ||
| 518 | +7x | +
+ estimate <- c(est1, est2)+ |
+ ||
| 519 | +7x | +
+ names(estimate) <- levels(grp)+ |
+ ||
| 520 | +7x | +
+ se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))+ |
+ ||
| 521 | +7x | +
+ se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))+ |
+ ||
| 522 | +7x | +
+ z <- stats::qnorm((1 + conf_level) / 2)+ |
+ ||
| 523 | +7x | +
+ err1 <- z * se1+ |
+ ||
| 524 | +7x | +
+ err2 <- z * se2+ |
+ ||
| 525 | +7x | +
+ ci1 <- c((est1 - err1), (est1 + err1))+ |
+ ||
| 526 | +7x | +
+ ci2 <- c((est2 - err2), (est2 + err2))+ |
+ ||
| 527 | +7x | +
+ estimate_ci <- list(ci1, ci2)+ |
+ ||
| 528 | +7x | +
+ names(estimate_ci) <- levels(grp)+ |
+ ||
| 529 | +7x | +
+ diff_est <- est2 - est1+ |
+ ||
| 530 | +7x | +
+ se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))+ |
+ ||
| 531 | +7x | +
+ diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)+ |
+ ||
| 532 | +||||
| 533 | +7x | +
+ list(+ |
+ ||
| 534 | +7x | +
+ prop = estimate,+ |
+ ||
| 535 | +7x | +
+ prop_ci = estimate_ci,+ |
+ ||
| 536 | +7x | +
+ diff = diff_est,+ |
+ ||
| 537 | +7x | +
+ diff_ci = diff_ci,+ |
+ ||
| 538 | +7x | +
+ weights = wt_normalized,+ |
+ ||
| 539 | +7x | +
+ n1 = n1,+ |
+ ||
| 540 | +7x | +
+ n2 = n2+ |
+ ||
| 509 | +541 |
- #' @describeIn default_stats_formats_labels Quick function to retrieve default labels for summary statistics.+ ) |
||
| 510 | +542 |
- #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`+ } |
||
| 511 | +543 |
- #'+ |
||
| 512 | +544 |
- #' @param include_pval (`flag`)\cr deprecated parameter. Same as `add_pval`.+ #' @describeIn h_prop_diff Calculates the stratified `Newcombe` confidence interval and difference in response |
||
| 513 | +545 |
- #' @return+ #' rates between the experimental treatment group and the control treatment group, adjusted for stratification |
||
| 514 | +546 |
- #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type.+ #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
|
||
| 515 | +547 | ++ |
+ #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from `CMH`-derived weights+ |
+ |
| 548 | ++ |
+ #' (see [prop_diff_cmh()]).+ |
+ ||
| 549 |
#' |
|||
| 516 | +550 |
- #' @examples+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 517 | +551 |
- #' summary_labels()+ #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"` |
||
| 518 | +552 |
- #' summary_labels(type = "counts", include_pval = TRUE)+ #' and directs the way weights are estimated. |
||
| 519 | +553 |
#' |
||
| 520 | +554 |
- #' @export+ #' @references |
||
| 521 | +555 |
- summary_labels <- function(type = "numeric", include_pval = FALSE) {
+ #' \insertRef{Yan2010-jt}{tern}
|
||
| 522 | -3x | +|||
| 556 | +
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ #' |
|||
| 523 | -3x | +|||
| 557 | +
- get_labels_from_stats(get_stats(met_grp, add_pval = include_pval))+ #' @examples |
|||
| 524 | +558 |
- }+ #' # Stratified `Newcombe` confidence interval |
||
| 525 | +559 |
-
+ #' |
||
| 526 | +560 |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")` Function to
+ #' set.seed(2) |
||
| 527 | +561 |
- #' configure settings for default or custom summary statistics for a given data type. In+ #' data_set <- data.frame( |
||
| 528 | +562 |
- #' addition to selecting a custom subset of statistics, the user can also set custom+ #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 529 | +563 |
- #' formats, labels, and indent modifiers for any of these statistics.+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 530 | +564 |
- #'+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 531 | +565 |
- #' @param stats_custom (`named vector` of `character`)\cr vector of statistics to include if+ #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
|
||
| 532 | +566 |
- #' not the defaults. This argument overrides `include_pval` and other custom value arguments+ #' stringsAsFactors = TRUE |
||
| 533 | +567 |
- #' such that only settings for these statistics will be returned.+ #' ) |
||
| 534 | +568 |
- #' @param formats_custom (`named vector` of `character`)\cr vector of custom statistics formats+ #' |
||
| 535 | +569 |
- #' to use in place of the defaults defined in [`summary_formats()`]. Names should be a subset+ #' prop_diff_strat_nc( |
||
| 536 | +570 |
- #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`).+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 537 | +571 |
- #' @param labels_custom (`named vector` of `character`)\cr vector of custom statistics labels+ #' weights_method = "cmh", |
||
| 538 | +572 |
- #' to use in place of the defaults defined in [`summary_labels()`]. Names should be a subset+ #' conf_level = 0.90 |
||
| 539 | +573 |
- #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`).+ #' ) |
||
| 540 | +574 |
- #' @param indent_mods_custom (`integer` or `named vector` of `integer`)\cr vector of custom+ #' |
||
| 541 | +575 |
- #' indentation modifiers for statistics to use instead of the default of `0L` for all statistics.+ #' prop_diff_strat_nc( |
||
| 542 | +576 |
- #' Names should be a subset of the statistics defined in `stats_custom` (or default statistics+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 543 | +577 |
- #' if this is `NULL`). Alternatively, the same indentation modifier can be applied to all+ #' weights_method = "wilson_h", |
||
| 544 | +578 |
- #' statistics by setting `indent_mods_custom` to a single integer value.+ #' conf_level = 0.90 |
||
| 545 | +579 | ++ |
+ #' )+ |
+ |
| 580 |
#' |
|||
| 546 | +581 |
- #' @return+ #' @export |
||
| 547 | +582 |
- #' * `summary_custom` returns a `list` of 4 named elements: `stats`, `formats`, `labels`,+ prop_diff_strat_nc <- function(rsp, |
||
| 548 | +583 |
- #' and `indent_mods`.+ grp, |
||
| 549 | +584 |
- #'+ strata, |
||
| 550 | +585 |
- #' @examples+ weights_method = c("cmh", "wilson_h"),
|
||
| 551 | +586 |
- #' summary_custom()+ conf_level = 0.95, |
||
| 552 | +587 |
- #' summary_custom(type = "counts", include_pval = TRUE)+ correct = FALSE) {
+ |
+ ||
| 588 | +4x | +
+ weights_method <- match.arg(weights_method)+ |
+ ||
| 589 | +4x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+ ||
| 590 | +4x | +
+ strata <- as_factor_keep_attributes(strata)+ |
+ ||
| 591 | +4x | +
+ check_diff_prop_ci(+ |
+ ||
| 592 | +4x | +
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
||
| 553 | +593 |
- #' summary_custom(+ )+ |
+ ||
| 594 | +4x | +
+ checkmate::assert_number(conf_level, lower = 0, upper = 1)+ |
+ ||
| 595 | +4x | +
+ checkmate::assert_flag(correct)+ |
+ ||
| 596 | +4x | +
+ if (any(tapply(rsp, strata, length) < 5)) {
+ |
+ ||
| 597 | +! | +
+ warning("Less than 5 observations in some strata.")
|
||
| 554 | +598 |
- #' include_pval = TRUE, stats_custom = c("n", "mean", "sd", "pval"),
+ } |
||
| 555 | +599 |
- #' labels_custom = c(sd = "Std. Dev."), indent_mods_custom = 3L+ + |
+ ||
| 600 | +4x | +
+ rsp_by_grp <- split(rsp, f = grp)+ |
+ ||
| 601 | +4x | +
+ strata_by_grp <- split(strata, f = grp) |
||
| 556 | +602 |
- #' )+ |
||
| 557 | +603 |
- #'+ # Finding the weights+ |
+ ||
| 604 | +4x | +
+ weights <- if (identical(weights_method, "cmh")) {
+ |
+ ||
| 605 | +3x | +
+ prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights+ |
+ ||
| 606 | +4x | +
+ } else if (identical(weights_method, "wilson_h")) {
+ |
+ ||
| 607 | +1x | +
+ prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights |
||
| 558 | +608 |
- #' @export+ }+ |
+ ||
| 609 | +4x | +
+ weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0 |
||
| 559 | +610 |
- summary_custom <- function(type = "numeric",+ |
||
| 560 | +611 | ++ |
+ # Calculating lower (`l`) and upper (`u`) confidence bounds per group.+ |
+ |
| 612 | +4x | +
+ strat_wilson_by_grp <- Map(+ |
+ ||
| 613 | +4x | +
+ prop_strat_wilson,+ |
+ ||
| 614 | +4x | +
+ rsp = rsp_by_grp,+ |
+ ||
| 615 | +4x | +
+ strata = strata_by_grp,+ |
+ ||
| 616 | +4x | +
+ weights = list(weights, weights),+ |
+ ||
| 617 | +4x | +
+ conf_level = conf_level,+ |
+ ||
| 618 | +4x | +
+ correct = correct+ |
+ ||
| 619 | ++ |
+ )+ |
+ ||
| 620 |
- include_pval = FALSE,+ + |
+ |||
| 621 | +4x | +
+ ci_ref <- strat_wilson_by_grp[[1]]+ |
+ ||
| 622 | +4x | +
+ ci_trt <- strat_wilson_by_grp[[2]]+ |
+ ||
| 623 | +4x | +
+ l_ref <- as.numeric(ci_ref$conf_int[1])+ |
+ ||
| 624 | +4x | +
+ u_ref <- as.numeric(ci_ref$conf_int[2]) |
||
| 561 | -+ | |||
| 625 | +4x |
- stats_custom = NULL,+ l_trt <- as.numeric(ci_trt$conf_int[1]) |
||
| 562 | -+ | |||
| 626 | +4x |
- formats_custom = NULL,+ u_trt <- as.numeric(ci_trt$conf_int[2]) |
||
| 563 | +627 |
- labels_custom = NULL,+ |
||
| 564 | +628 |
- indent_mods_custom = NULL) {
+ # Estimating the diff and n_ref, n_trt (it allows different weights to be used) |
||
| 565 | -1x | +629 | +4x |
- lifecycle::deprecate_warn(+ t_tbl <- table( |
| 566 | -1x | +630 | +4x |
- "0.9.0.9001",+ factor(rsp, levels = c("FALSE", "TRUE")),
|
| 567 | -1x | +631 | +4x |
- "summary_custom()",+ grp, |
| 568 | -1x | +632 | +4x |
- details = "Please use `get_stats`, `get_formats_from_stats`, and `get_labels_from_stats` directly instead."+ strata |
| 569 | +633 |
) |
||
| 570 | -1x | +634 | +4x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ n_ref <- colSums(t_tbl[1:2, 1, ]) |
| 571 | -1x | +635 | +4x |
- .stats <- get_stats(met_grp, stats_custom, add_pval = include_pval)+ n_trt <- colSums(t_tbl[1:2, 2, ]) |
| 572 | -1x | +636 | +4x |
- .formats <- get_formats_from_stats(.stats, formats_custom)+ use_stratum <- (n_ref > 0) & (n_trt > 0) |
| 573 | -1x | +637 | +4x |
- .labels <- get_labels_from_stats(.stats, labels_custom)+ n_ref <- n_ref[use_stratum] |
| 574 | -1x | +638 | +4x |
- .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats)+ n_trt <- n_trt[use_stratum] |
| 575 | -+ | |||
| 639 | +4x |
-
+ p_ref <- t_tbl[2, 1, use_stratum] / n_ref |
||
| 576 | -1x | +640 | +4x |
- if (!is.null(indent_mods_custom)) {
+ p_trt <- t_tbl[2, 2, use_stratum] / n_trt |
| 577 | -! | +|||
| 641 | +4x |
- if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
+ est1 <- sum(weights * p_ref) |
||
| 578 | -! | +|||
| 642 | +4x |
- .indent_mods[names(.indent_mods)] <- indent_mods_custom+ est2 <- sum(weights * p_trt)+ |
+ ||
| 643 | +4x | +
+ diff_est <- est2 - est1 |
||
| 579 | +644 |
- } else {
+
|
||
| 580 | -! | +|||
| 645 | +4x |
- .indent_mods[names(indent_mods_custom)] <- indent_mods_custom+ lambda1 <- sum(weights^2 / n_ref) |
||
| 581 | -+ | |||
| 646 | +4x |
- }+ lambda2 <- sum(weights^2 / n_trt) |
||
| 582 | -+ | |||
| 647 | +4x |
- }+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 583 | +648 | |||
| 584 | -1x | +649 | +4x |
- list(+ lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref)) |
| 585 | -1x | +650 | +4x |
- stats = .stats,+ upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ |
+
| 651 | ++ | + | ||
| 586 | -1x | +652 | +4x |
- formats = .formats,+ list( |
| 587 | -1x | +653 | +4x |
- labels = .labels,+ "diff" = diff_est, |
| 588 | -1x | +654 | +4x |
- indent_mods = .indent_mods[.stats]+ "diff_ci" = c("lower" = lower, "upper" = upper)
|
| 589 | +655 |
) |
||
| 590 | +656 |
}@@ -105701,14 +107388,14 @@ tern coverage - 90.46% |
| 1 |
- #' Line plot with the optional table+ #' Incidence Rate |
|||
| 5 |
- #' Line plot with the optional table.+ #' Estimate the event rate adjusted for person-years at risk, otherwise known |
|||
| 6 |
- #'+ #' as incidence rate. Primary analysis variable is the person-years at risk. |
|||
| 7 |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ #' |
|||
| 8 |
- #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only)+ #' @inheritParams argument_convention |
|||
| 9 |
- #' to counts objects in groups for stratification.+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
|||
| 10 |
- #' @param variables (named `character` vector) of variable names in `df` data set. Details are:+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
|||
| 11 |
- #' * `x` (`character`)\cr name of x-axis variable.+ #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate. |
|||
| 12 |
- #' * `y` (`character`)\cr name of y-axis variable.+ #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
|||
| 13 |
- #' * `group_var` (`character`)\cr name of grouping variable (or strata), i.e. treatment arm.+ #' for confidence interval type. |
|||
| 14 |
- #' Can be `NA` to indicate lack of groups.+ #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default) |
|||
| 15 |
- #' * `subject_var` (`character`)\cr name of subject variable. Only applies if `group_var` is+ #' indicating time unit for data input. |
|||
| 16 |
- #' not NULL.+ #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years). |
|||
| 17 |
- #' * `paramcd` (`character`)\cr name of the variable for parameter's code. Used for y-axis label and plot's subtitle.+ #' @param n_events (`integer`)\cr number of events observed. |
|||
| 18 |
- #' Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_incidence_rate")`
|
|||
| 19 |
- #' * `y_unit` (`character`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.+ #' to see available statistics for this function. |
|||
| 20 |
- #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle.+ #' |
|||
| 21 |
- #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.+ #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate]. |
|||
| 22 |
- #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,+ #' |
|||
| 23 |
- #' and be of a `double` or `numeric` type vector of length one.+ #' @name incidence_rate |
|||
| 24 |
- #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.+ #' @order 1 |
|||
| 25 |
- #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,+ NULL |
|||
| 26 |
- #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be+ |
|||
| 27 |
- #' added to the plot.+ #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the |
|||
| 28 |
- #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names+ #' associated confidence interval. |
|||
| 29 |
- #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of+ #' |
|||
| 30 |
- #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting+ #' @return |
|||
| 31 |
- #' `interval = NULL`.+ #' * `s_incidence_rate()` returns the following statistics: |
|||
| 32 |
- #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.+ #' - `person_years`: Total person-years at risk. |
|||
| 33 |
- #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`.+ #' - `n_events`: Total number of events observed. |
|||
| 34 |
- #' @param sfun (`closure`)\cr the function to compute the values of required statistics. It must return a named `list`+ #' - `rate`: Estimated incidence rate. |
|||
| 35 |
- #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,+ #' - `rate_ci`: Confidence interval for the incidence rate. |
|||
| 36 |
- #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.+ #' |
|||
| 37 |
- #' @param ... optional arguments to `sfun`.+ #' @keywords internal |
|||
| 38 |
- #' @param mid_type (`character`)\cr controls the type of the `mid` plot, it can be point (`p`), line (`l`),+ s_incidence_rate <- function(df, |
|||
| 39 |
- #' or point and line (`pl`).+ .var, |
|||
| 40 |
- #' @param mid_point_size (`integer` or `double`)\cr controls the font size of the point for `mid` plot.+ n_events, |
|||
| 41 |
- #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of+ is_event, |
|||
| 42 |
- #' a call to a position adjustment function.+ control = control_incidence_rate()) {
|
|||
| 43 | -+ | 1x |
- #' @param legend_title (`character` string)\cr legend title.+ if (!missing(is_event)) {
|
|
| 44 | -+ | ! |
- #' @param legend_position (`character`)\cr the position of the plot legend (`none`, `left`, `right`, `bottom`, `top`,+ warning("argument is_event will be deprecated. Please use n_events.")
|
|
| 45 |
- #' or two-element numeric vector).+ |
|||
| 46 | -+ | ! |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ if (missing(n_events)) {
|
|
| 47 | -+ | ! |
- #' @param x_lab (`character`)\cr x-axis label. If equal to `NULL`, then no label will be added.+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
|
| 48 | -+ | ! |
- #' @param y_lab (`character`)\cr y-axis label. If equal to `NULL`, then no label will be added.+ checkmate::assert_string(.var) |
|
| 49 | -+ | ! |
- #' @param y_lab_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to the+ checkmate::assert_logical(df[[is_event]], any.missing = FALSE) |
|
| 50 | -+ | ! |
- #' y-axis label `y_lab`?+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE) |
|
| 51 | -+ | ! |
- #' @param y_lab_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the y-axis+ n_events <- is_event |
|
| 52 |
- #' label `y_lab`?+ } |
|||
| 53 |
- #' @param title (`character`)\cr plot title.+ } else {
|
|||
| 54 | -+ | 1x |
- #' @param subtitle (`character`)\cr plot subtitle.+ assert_df_with_variables(df, list(tte = .var, n_events = n_events)) |
|
| 55 | -+ | 1x |
- #' @param subtitle_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to+ checkmate::assert_string(.var) |
|
| 56 | -+ | 1x |
- #' the plot's subtitle `subtitle`?+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE) |
|
| 57 | -+ | 1x |
- #' @param subtitle_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the+ checkmate::assert_integer(df[[n_events]], any.missing = FALSE) |
|
| 58 |
- #' plot's subtitle `subtitle`?+ } |
|||
| 59 |
- #' @param caption (`character`)\cr optional caption below the plot.+ |
|||
| 60 | -+ | 1x |
- #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the+ input_time_unit <- control$input_time_unit |
|
| 61 | -+ | 1x |
- #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`+ num_pt_year <- control$num_pt_year |
|
| 62 | -+ | 1x |
- #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.+ conf_level <- control$conf_level |
|
| 63 | -+ | 1x |
- #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table+ person_years <- sum(df[[.var]], na.rm = TRUE) * ( |
|
| 64 | -+ | 1x |
- #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.+ 1 * (input_time_unit == "year") + |
|
| 65 | -+ | 1x |
- #' @param table_font_size (`integer` or `double`)\cr controls the font size of values in the table.+ 1 / 12 * (input_time_unit == "month") + |
|
| 66 | -+ | 1x |
- #' @param newpage (`logical`)\cr should plot be drawn on new page?+ 1 / 52.14 * (input_time_unit == "week") + |
|
| 67 | -+ | 1x |
- #' @param col (`character`)\cr colors.+ 1 / 365.24 * (input_time_unit == "day") |
|
| 68 |
- #'+ ) |
|||
| 69 | -+ | 1x |
- #' @return A `ggplot` line plot (and statistics table if applicable).+ n_events <- sum(df[[n_events]], na.rm = TRUE) |
|
| 70 |
- #'+ |
|||
| 71 | -+ | 1x |
- #' @examples+ result <- h_incidence_rate( |
|
| 72 | -+ | 1x |
- #' library(nestcolor)+ person_years, |
|
| 73 | -+ | 1x |
- #'+ n_events, |
|
| 74 | -+ | 1x |
- #' adsl <- tern_ex_adsl+ control |
|
| 75 |
- #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")+ ) |
|||
| 76 | -+ | 1x |
- #' adlb$AVISIT <- droplevels(adlb$AVISIT)+ list( |
|
| 77 | -+ | 1x |
- #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))+ person_years = formatters::with_label(person_years, "Total patient-years at risk"), |
|
| 78 | -+ | 1x |
- #'+ n_events = formatters::with_label(n_events, "Number of adverse events observed"), |
|
| 79 | -+ | 1x |
- #' # Mean with CI+ rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
|
|
| 80 | -+ | 1x |
- #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")+ rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)) |
|
| 81 |
- #'+ ) |
|||
| 82 |
- #' # Mean with CI, no stratification with group_var+ } |
|||
| 83 |
- #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA))+ |
|||
| 84 |
- #'+ #' @describeIn incidence_rate Formatted analysis function which is used as `afun` |
|||
| 85 |
- #' # Mean, upper whisker of CI, no group_var(strata) counts N+ #' in `estimate_incidence_rate()`. |
|||
| 86 |
- #' g_lineplot(+ #' |
|||
| 87 |
- #' adlb,+ #' @return |
|||
| 88 |
- #' whiskers = "mean_ci_upr",+ #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 89 |
- #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit"+ #' |
|||
| 90 |
- #' )+ #' @keywords internal |
|||
| 91 |
- #'+ a_incidence_rate <- make_afun( |
|||
| 92 |
- #' # Median with CI+ s_incidence_rate, |
|||
| 93 |
- #' g_lineplot(+ .formats = c( |
|||
| 94 |
- #' adlb,+ "person_years" = "xx.x", |
|||
| 95 |
- #' adsl,+ "n_events" = "xx", |
|||
| 96 |
- #' mid = "median",+ "rate" = "xx.xx", |
|||
| 97 |
- #' interval = "median_ci",+ "rate_ci" = "(xx.xx, xx.xx)" |
|||
| 98 |
- #' whiskers = c("median_ci_lwr", "median_ci_upr"),
+ ) |
|||
| 99 |
- #' title = "Plot of Median and 95% Confidence Limits by Visit"+ ) |
|||
| 100 |
- #' )+ |
|||
| 101 |
- #'+ #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments |
|||
| 102 |
- #' # Mean, +/- SD+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 103 |
- #' g_lineplot(adlb, adsl,+ #' |
|||
| 104 |
- #' interval = "mean_sdi",+ #' @return |
|||
| 105 |
- #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
+ #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions, |
|||
| 106 |
- #' title = "Plot of Median +/- SD by Visit"+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 107 |
- #' )+ #' the statistics from `s_incidence_rate()` to the table layout. |
|||
| 109 |
- #' # Mean with CI plot with stats table+ #' @examples |
|||
| 110 |
- #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
+ #' library(dplyr) |
|||
| 112 |
- #' # Mean with CI, table and customized confidence level+ #' df <- data.frame( |
|||
| 113 |
- #' g_lineplot(+ #' USUBJID = as.character(seq(6)), |
|||
| 114 |
- #' adlb,+ #' CNSR = c(0, 1, 1, 0, 0, 0), |
|||
| 115 |
- #' adsl,+ #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4), |
|||
| 116 |
- #' table = c("n", "mean", "mean_ci"),
+ #' ARM = factor(c("A", "A", "A", "B", "B", "B"))
|
|||
| 117 |
- #' control = control_analyze_vars(conf_level = 0.80),+ #' ) %>% |
|||
| 118 |
- #' title = "Plot of Mean and 80% Confidence Limits by Visit"+ #' mutate(is_event = CNSR == 0) %>% |
|||
| 119 |
- #' )+ #' mutate(n_events = as.integer(is_event)) |
|||
| 121 |
- #' # Mean with CI, table, filtered data+ #' basic_table() %>% |
|||
| 122 |
- #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE")+ #' split_cols_by("ARM") %>%
|
|||
| 123 |
- #' g_lineplot(adlb_f, table = c("n", "mean"))
+ #' add_colcounts() %>% |
|||
| 124 |
- #'+ #' estimate_incidence_rate( |
|||
| 125 |
- #' @export+ #' vars = "AVAL", |
|||
| 126 |
- g_lineplot <- function(df,+ #' n_events = "n_events", |
|||
| 127 |
- alt_counts_df = NULL,+ #' control = control_incidence_rate( |
|||
| 128 |
- variables = control_lineplot_vars(),+ #' input_time_unit = "month", |
|||
| 129 |
- mid = "mean",+ #' num_pt_year = 100 |
|||
| 130 |
- interval = "mean_ci",+ #' ) |
|||
| 131 |
- whiskers = c("mean_ci_lwr", "mean_ci_upr"),
+ #' ) %>% |
|||
| 132 |
- table = NULL,+ #' build_table(df) |
|||
| 133 |
- sfun = tern::s_summary,+ #' |
|||
| 134 |
- ...,+ #' @export |
|||
| 135 |
- mid_type = "pl",+ #' @order 2 |
|||
| 136 |
- mid_point_size = 2,+ estimate_incidence_rate <- function(lyt, |
|||
| 137 |
- position = ggplot2::position_dodge(width = 0.4),+ vars, |
|||
| 138 |
- legend_title = NULL,+ n_events, |
|||
| 139 |
- legend_position = "bottom",+ control = control_incidence_rate(), |
|||
| 140 |
- ggtheme = nestcolor::theme_nest(),+ na_str = default_na_str(), |
|||
| 141 |
- x_lab = obj_label(df[[variables[["x"]]]]),- |
- |||
| 142 | -- |
- y_lab = NULL,- |
- ||
| 143 | -- |
- y_lab_add_paramcd = TRUE,- |
- ||
| 144 | -- |
- y_lab_add_unit = TRUE,- |
- ||
| 145 | -- |
- title = "Plot of Mean and 95% Confidence Limits by Visit",- |
- ||
| 146 | -- |
- subtitle = "",- |
- ||
| 147 | -- |
- subtitle_add_paramcd = TRUE,- |
- ||
| 148 | -- |
- subtitle_add_unit = TRUE,- |
- ||
| 149 | -- |
- caption = NULL,- |
- ||
| 150 | -- |
- table_format = summary_formats(),- |
- ||
| 151 | -- |
- table_labels = summary_labels(),- |
- ||
| 152 | -- |
- table_font_size = 3,- |
- ||
| 153 | -- |
- newpage = TRUE,- |
- ||
| 154 | -- |
- col = NULL) {
- |
- ||
| 155 | -3x | -
- checkmate::assert_character(variables, any.missing = TRUE)- |
- ||
| 156 | -3x | -
- checkmate::assert_character(mid, null.ok = TRUE)- |
- ||
| 157 | -3x | -
- checkmate::assert_character(interval, null.ok = TRUE)- |
- ||
| 158 | -3x | -
- checkmate::assert_character(col, null.ok = TRUE)- |
- ||
| 159 | -- | - - | -||
| 160 | -3x | -
- checkmate::assert_string(title, null.ok = TRUE)- |
- ||
| 161 | -3x | -
- checkmate::assert_string(subtitle, null.ok = TRUE)- |
- ||
| 162 | -- | - - | -||
| 163 | -3x | -
- if (is.character(interval)) {
- |
- ||
| 164 | -3x | -
- checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)- |
- ||
| 165 | -- |
- }- |
- ||
| 166 | -- | - - | -||
| 167 | -3x | -
- if (length(whiskers) == 1) {
- |
- ||
| 168 | -! | -
- checkmate::assert_character(mid)- |
- ||
| 169 | -- |
- }- |
- ||
| 170 | -- | - - | -||
| 171 | -3x | -
- if (is.character(mid)) {
- |
- ||
| 172 | -3x | -
- checkmate::assert_scalar(mid_type)- |
- ||
| 173 | -3x | -
- checkmate::assert_subset(mid_type, c("pl", "p", "l"))
- |
- ||
| 174 | -- |
- }- |
- ||
| 175 | -- | - - | -||
| 176 | -3x | -
- x <- variables[["x"]]- |
- ||
| 177 | -3x | -
- y <- variables[["y"]]- |
- ||
| 178 | -3x | -
- paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables- |
- ||
| 179 | -3x | -
- y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables- |
- ||
| 180 | -3x | -
- if (is.na(variables["group_var"])) {
- |
- ||
| 181 | -! | -
- group_var <- NULL # NULL if group_var == NA or it is not in variables- |
- ||
| 182 | -- |
- } else {
- |
- ||
| 183 | -3x | -
- group_var <- variables[["group_var"]]- |
- ||
| 184 | -3x | -
- subject_var <- variables[["subject_var"]]- |
- ||
| 185 | -- |
- }- |
- ||
| 186 | -3x | -
- checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)- |
- ||
| 187 | -3x | -
- checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)- |
- ||
| 188 | -3x | -
- if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
- |
- ||
| 189 | -3x | -
- checkmate::assert_false(is.na(paramcd))- |
- ||
| 190 | -3x | -
- checkmate::assert_scalar(unique(df[[paramcd]]))- |
- ||
| 191 | -- |
- }- |
- ||
| 192 | -- | - - | -||
| 193 | -3x | -
- checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)- |
- ||
| 194 | -3x | -
- checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)- |
- ||
| 195 | -3x | -
- if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
- |
- ||
| 196 | -3x | -
- checkmate::assert_false(is.na(y_unit))- |
- ||
| 197 | -3x | -
- checkmate::assert_scalar(unique(df[[y_unit]]))- |
- ||
| 198 | -- |
- }- |
- ||
| 199 | -- | - - | -||
| 200 | -3x | -
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
- |
- ||
| 201 | -3x | -
- checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]]))- |
- ||
| 202 | -- |
- }- |
- ||
| 203 | -- | - - | -||
| 204 | -- |
- ####################################### |+ nested = TRUE, |
||
| 205 | +142 |
- # ---- Compute required statistics ----+ ..., |
||
| 206 | +143 |
- ####################################### |+ show_labels = "hidden", |
||
| 207 | -3x | +|||
| 144 | +
- if (!is.null(group_var)) {
+ table_names = vars, |
|||
| 208 | -3x | +|||
| 145 | +
- df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors+ .stats = NULL, |
|||
| 209 | +146 |
- } else {
+ .formats = NULL, |
||
| 210 | -! | +|||
| 147 | +
- df_grp <- tidyr::expand(df, NULL, .data[[x]])+ .labels = NULL, |
|||
| 211 | +148 |
- }+ .indent_mods = NULL) {
|
||
| 212 | -3x | +149 | +1x |
- df_grp <- df_grp %>%+ extra_args <- list(n_events = n_events, control = control, ...) |
| 213 | -3x | +|||
| 150 | +
- dplyr::full_join(y = df[, c(group_var, x, y)], by = c(group_var, x), multiple = "all") %>%+ |
|||
| 214 | -3x | +151 | +1x |
- dplyr::group_by_at(c(group_var, x))+ afun <- make_afun( |
| 215 | -+ | |||
| 152 | +1x |
-
+ a_incidence_rate, |
||
| 216 | -3x | +153 | +1x |
- df_stats <- df_grp %>%+ .stats = .stats, |
| 217 | -3x | +154 | +1x |
- dplyr::summarise(+ .formats = .formats, |
| 218 | -3x | +155 | +1x |
- data.frame(t(do.call(c, unname(sfun(.data[[y]], ...)[c(mid, interval)])))),+ .labels = .labels, |
| 219 | -3x | +156 | +1x |
- .groups = "drop"+ .indent_mods = .indent_mods |
| 220 | +157 |
- )+ ) |
||
| 221 | +158 | |||
| 222 | -3x | +159 | +1x |
- df_stats <- df_stats[!is.na(df_stats[[mid]]), ]+ analyze( |
| 223 | -+ | |||
| 160 | +1x |
-
+ lyt, |
||
| 224 | -+ | |||
| 161 | +1x |
- # add number of objects N in group_var (strata)+ vars, |
||
| 225 | -3x | +162 | +1x |
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ show_labels = show_labels, |
| 226 | -3x | +163 | +1x |
- strata_N <- paste0(group_var, "_N") # nolint+ table_names = table_names, |
| 227 | -+ | |||
| 164 | +1x |
-
+ afun = afun, |
||
| 228 | -3x | +165 | +1x |
- 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+ na_str = na_str, |
| 229 | -3x | +166 | +1x |
- colnames(df_N) <- c(group_var, "N") # nolint+ nested = nested, |
| 230 | -3x | +167 | +1x |
- df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint+ extra_args = extra_args |
| 231 | +168 |
-
+ ) |
||
| 232 | +169 |
- # strata_N should not be in clonames(df_stats)- |
- ||
| 233 | -3x | -
- checkmate::assert_disjunct(strata_N, colnames(df_stats))+ } |
||
| 234 | +170 | |||
| 235 | -3x | -
- df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var)- |
- ||
| 236 | -! | -
- } else if (!is.null(group_var)) {
- |
- ||
| 237 | -! | -
- strata_N <- group_var # nolint- |
- ||
| 238 | +171 |
- } else {
- |
- ||
| 239 | -! | -
- strata_N <- NULL # nolint+ #' Helper Functions for Incidence Rate |
||
| 240 | +172 |
- }+ #' |
||
| 241 | +173 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 242 | +174 |
- ############################################### |+ #' |
||
| 243 | +175 |
- # ---- Prepare certain plot's properties. ----+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
||
| 244 | +176 |
- ############################################### |+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
||
| 245 | +177 |
- # legend title- |
- ||
| 246 | -3x | -
- if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
+ #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate. |
||
| 247 | -3x | +|||
| 178 | +
- legend_title <- attr(df[[group_var]], "label")+ #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
|||
| 248 | +179 |
- }+ #' for confidence interval type. |
||
| 249 | +180 |
-
+ #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 250 | +181 |
- # y label+ #' indicating time unit for data input. |
||
| 251 | -3x | +|||
| 182 | +
- if (!is.null(y_lab)) {
+ #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years). |
|||
| 252 | -2x | +|||
| 183 | +
- if (y_lab_add_paramcd) {
+ #' @param person_years (`numeric`)\cr total person-years at risk. |
|||
| 253 | -2x | +|||
| 184 | +
- y_lab <- paste(y_lab, unique(df[[paramcd]]))+ #' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval. |
|||
| 254 | +185 |
- }+ #' @param n_events (`integer`)\cr number of events observed. |
||
| 255 | +186 |
-
+ #' |
||
| 256 | -2x | +|||
| 187 | +
- if (y_lab_add_unit) {
+ #' @return Estimated incidence rate `rate` and associated confidence interval `rate_ci`. |
|||
| 257 | -2x | +|||
| 188 | +
- y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
+ #' |
|||
| 258 | +189 |
- }+ #' @seealso [incidence_rate] |
||
| 259 | +190 |
-
+ #' |
||
| 260 | -2x | +|||
| 191 | +
- y_lab <- trimws(y_lab)+ #' @name h_incidence_rate |
|||
| 261 | +192 |
- }+ NULL |
||
| 262 | +193 | |||
| 263 | +194 |
- # subtitle- |
- ||
| 264 | -3x | -
- if (!is.null(subtitle)) {
- |
- ||
| 265 | -3x | -
- if (subtitle_add_paramcd) {
- |
- ||
| 266 | -3x | -
- subtitle <- paste(subtitle, unique(df[[paramcd]]))+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 267 | +195 |
- }+ #' associated confidence interval based on the normal approximation for the |
||
| 268 | +196 | - - | -||
| 269 | -3x | -
- if (subtitle_add_unit) {
- |
- ||
| 270 | -3x | -
- subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
+ #' incidence rate. Unit is one person-year. |
||
| 271 | +197 |
- }+ #' |
||
| 272 | +198 |
-
+ #' @examples |
||
| 273 | -3x | +|||
| 199 | +
- subtitle <- trimws(subtitle)+ #' h_incidence_rate_normal(200, 2) |
|||
| 274 | +200 |
- }+ #' |
||
| 275 | +201 |
-
+ #' @export |
||
| 276 | +202 |
- ############################### |+ h_incidence_rate_normal <- function(person_years, |
||
| 277 | +203 |
- # ---- Build plot object. ----+ n_events, |
||
| 278 | +204 |
- ############################### |+ alpha = 0.05) {
|
||
| 279 | -3x | +205 | +1x |
- p <- ggplot2::ggplot(+ checkmate::assert_number(person_years) |
| 280 | -3x | +206 | +1x |
- data = df_stats,+ checkmate::assert_number(n_events) |
| 281 | -3x | +207 | +1x |
- mapping = ggplot2::aes(+ assert_proportion_value(alpha) |
| 282 | -3x | +|||
| 208 | +
- x = .data[[x]], y = .data[[mid]],+ |
|||
| 283 | -3x | +209 | +1x |
- color = if (is.null(strata_N)) NULL else .data[[strata_N]],+ est <- n_events / person_years |
| 284 | -3x | +210 | +1x |
- shape = if (is.null(strata_N)) NULL else .data[[strata_N]],+ se <- sqrt(est / person_years) |
| 285 | -3x | +211 | +1x |
- lty = if (is.null(strata_N)) NULL else .data[[strata_N]],+ ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se |
| 286 | -3x | +|||
| 212 | +
- group = if (is.null(strata_N)) NULL else .data[[strata_N]]+ |
|||
| 287 | -+ | |||
| 213 | +1x |
- )+ list(rate = est, rate_ci = ci) |
||
| 288 | +214 |
- )+ } |
||
| 289 | +215 | |||
| 290 | -3x | -
- if (!is.null(mid)) {
- |
- ||
| 291 | +216 |
- # points- |
- ||
| 292 | -3x | -
- if (grepl("p", mid_type, fixed = TRUE)) {
- |
- ||
| 293 | -3x | -
- p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 294 | +217 |
- }+ #' associated confidence interval based on the normal approximation for the |
||
| 295 | +218 |
-
+ #' logarithm of the incidence rate. Unit is one person-year. |
||
| 296 | +219 |
- # lines+ #' |
||
| 297 | +220 |
- # further conditions in if are to ensure that not all of the groups consist of only one observation+ #' @examples |
||
| 298 | -3x | +|||
| 221 | +
- if (grepl("l", mid_type, fixed = TRUE) && !is.null(group_var) &&
+ #' h_incidence_rate_normal_log(200, 2) |
|||
| 299 | -3x | +|||
| 222 | +
- !all(dplyr::summarise(df_grp, count_n = dplyr::n())[["count_n"]] == 1L)) { # nolint
+ #' |
|||
| 300 | -3x | +|||
| 223 | +
- p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)+ #' @export |
|||
| 301 | +224 |
- }+ h_incidence_rate_normal_log <- function(person_years, |
||
| 302 | +225 |
- }+ n_events, |
||
| 303 | +226 |
-
+ alpha = 0.05) {
|
||
| 304 | -+ | |||
| 227 | +5x |
- # interval+ checkmate::assert_number(person_years) |
||
| 305 | -3x | +228 | +5x |
- if (!is.null(interval)) {
+ checkmate::assert_number(n_events) |
| 306 | -3x | +229 | +5x |
- p <- p ++ assert_proportion_value(alpha)+ |
+
| 230 | ++ | + | ||
| 307 | -3x | +231 | +5x |
- ggplot2::geom_errorbar(+ rate_est <- n_events / person_years |
| 308 | -3x | +232 | +5x |
- ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),+ rate_se <- sqrt(rate_est / person_years) |
| 309 | -3x | +233 | +5x |
- width = 0.45,+ lrate_est <- log(rate_est) |
| 310 | -3x | +234 | +5x |
- position = position+ lrate_se <- rate_se / rate_est |
| 311 | -+ | |||
| 235 | +5x |
- )+ ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se) |
||
| 312 | +236 | |||
| 313 | -3x | +237 | +5x |
- if (length(whiskers) == 1) { # lwr or upr only; mid is then required
+ list(rate = rate_est, rate_ci = ci) |
| 314 | +238 |
- # workaround as geom_errorbar does not provide single-direction whiskers+ } |
||
| 315 | -! | +|||
| 239 | +
- p <- p ++ |
|||
| 316 | -! | +|||
| 240 | +
- ggplot2::geom_linerange(+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|||
| 317 | -! | +|||
| 241 | +
- data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings+ #' associated exact confidence interval. Unit is one person-year. |
|||
| 318 | -! | +|||
| 242 | +
- ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),+ #' |
|||
| 319 | -! | +|||
| 243 | +
- position = position,+ #' @examples |
|||
| 320 | -! | +|||
| 244 | +
- na.rm = TRUE,+ #' h_incidence_rate_exact(200, 2) |
|||
| 321 | -! | +|||
| 245 | +
- show.legend = FALSE+ #' |
|||
| 322 | +246 |
- )+ #' @export |
||
| 323 | +247 |
- }+ h_incidence_rate_exact <- function(person_years, |
||
| 324 | +248 |
- }+ n_events, |
||
| 325 | +249 |
-
+ alpha = 0.05) {
|
||
| 326 | -3x | +250 | +1x |
- p <- p ++ checkmate::assert_number(person_years) |
| 327 | -3x | +251 | +1x |
- ggplot2::scale_y_continuous(labels = scales::comma) ++ checkmate::assert_number(n_events) |
| 328 | -3x | +252 | +1x |
- ggplot2::labs(+ assert_proportion_value(alpha) |
| 329 | -3x | +|||
| 253 | +
- title = title,+ |
|||
| 330 | -3x | +254 | +1x |
- subtitle = subtitle,+ est <- n_events / person_years |
| 331 | -3x | +255 | +1x |
- caption = caption,+ lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years) |
| 332 | -3x | +256 | +1x |
- color = legend_title,+ ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years) |
| 333 | -3x | +|||
| 257 | +
- lty = legend_title,+ |
|||
| 334 | -3x | +258 | +1x |
- shape = legend_title,+ list(rate = est, rate_ci = c(lcl, ucl)) |
| 335 | -3x | +|||
| 259 | +
- x = x_lab,+ } |
|||
| 336 | -3x | +|||
| 260 | +
- y = y_lab+ |
|||
| 337 | +261 |
- )+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 338 | +262 |
-
+ #' associated `Byar`'s confidence interval. Unit is one person-year. |
||
| 339 | -3x | +|||
| 263 | +
- if (!is.null(col)) {
+ #' |
|||
| 340 | -! | +|||
| 264 | +
- p <- p ++ #' @examples |
|||
| 341 | -! | +|||
| 265 | +
- ggplot2::scale_color_manual(values = col)+ #' h_incidence_rate_byar(200, 2) |
|||
| 342 | +266 |
- }+ #' |
||
| 343 | +267 |
-
+ #' @export |
||
| 344 | -3x | +|||
| 268 | +
- if (!is.null(ggtheme)) {
+ h_incidence_rate_byar <- function(person_years, |
|||
| 345 | -3x | +|||
| 269 | +
- p <- p + ggtheme+ n_events, |
|||
| 346 | +270 |
- } else {
+ alpha = 0.05) {
|
||
| 347 | -! | +|||
| 271 | +1x |
- p <- p ++ checkmate::assert_number(person_years) |
||
| 348 | -! | +|||
| 272 | +1x |
- ggplot2::theme_bw() ++ checkmate::assert_number(n_events) |
||
| 349 | -! | +|||
| 273 | +1x |
- ggplot2::theme(+ assert_proportion_value(alpha) |
||
| 350 | -! | +|||
| 274 | +
- legend.key.width = grid::unit(1, "cm"),+ |
|||
| 351 | -! | +|||
| 275 | +1x |
- legend.position = legend_position,+ est <- n_events / person_years |
||
| 352 | -! | +|||
| 276 | +1x |
- legend.direction = ifelse(+ seg_1 <- n_events + 0.5 |
||
| 353 | -! | +|||
| 277 | +1x |
- legend_position %in% c("top", "bottom"),
+ seg_2 <- 1 - 1 / (9 * (n_events + 0.5)) |
||
| 354 | -! | +|||
| 278 | +1x |
- "horizontal",+ seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3 |
||
| 355 | -! | +|||
| 279 | +1x |
- "vertical"+ lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years |
||
| 356 | -+ | |||
| 280 | +1x |
- )+ ucl <- seg_1 * ((seg_2 + seg_3) ^ 3) / person_years # styler: off |
||
| 357 | +281 |
- )+ + |
+ ||
| 282 | +1x | +
+ list(rate = est, rate_ci = c(lcl, ucl)) |
||
| 358 | +283 |
- }+ } |
||
| 359 | +284 | |||
| 360 | +285 |
- ############################################################# |+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 361 | +286 |
- # ---- Optionally, add table to the bottom of the plot. ----+ #' associated confidence interval. |
||
| 362 | +287 |
- ############################################################# |+ #' |
||
| 363 | -3x | +|||
| 288 | +
- if (!is.null(table)) {
+ #' @keywords internal |
|||
| 364 | -2x | +|||
| 289 | +
- df_stats_table <- df_grp %>%+ h_incidence_rate <- function(person_years, |
|||
| 365 | -2x | +|||
| 290 | +
- dplyr::summarise(+ n_events, |
|||
| 366 | -2x | +|||
| 291 | +
- h_format_row(+ control = control_incidence_rate()) {
|
|||
| 367 | -2x | +292 | +4x |
- x = sfun(.data[[y]], ...)[table],+ alpha <- 1 - control$conf_level |
| 368 | -2x | +293 | +4x |
- format = table_format,+ est <- switch(control$conf_type, |
| 369 | -2x | +294 | +4x |
- labels = table_labels+ normal = h_incidence_rate_normal(person_years, n_events, alpha), |
| 370 | -+ | |||
| 295 | +4x |
- ),+ normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha), |
||
| 371 | -2x | +296 | +4x |
- .groups = "drop"+ exact = h_incidence_rate_exact(person_years, n_events, alpha), |
| 372 | -+ | |||
| 297 | +4x |
- )+ byar = h_incidence_rate_byar(person_years, n_events, alpha) |
||
| 373 | +298 | - - | -||
| 374 | -2x | -
- stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x)))+ ) |
||
| 375 | +299 | |||
| 376 | -2x | +300 | +4x |
- df_stats_table <- df_stats_table %>%+ num_pt_year <- control$num_pt_year |
| 377 | -2x | +301 | +4x |
- tidyr::pivot_longer(+ list( |
| 378 | -2x | +302 | +4x |
- cols = -dplyr::all_of(c(group_var, x)),+ rate = est$rate * num_pt_year, |
| 379 | -2x | +303 | +4x |
- names_to = "stat",+ rate_ci = est$rate_ci * num_pt_year |
| 380 | -2x | +|||
| 304 | +
- values_to = "value",+ ) |
|||
| 381 | -2x | +|||
| 305 | +
- names_ptypes = list(stat = factor(levels = stats_lev))+ } |
| 382 | +1 |
- )+ #' Helper Function to create a new `SMQ` variable in `ADAE` by stacking `SMQ` and/or `CQ` records. |
||
| 383 | +2 |
-
+ #' |
||
| 384 | -2x | +|||
| 3 | +
- tbl <- ggplot2::ggplot(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 385 | -2x | +|||
| 4 | +
- df_stats_table,+ #' |
|||
| 386 | -2x | +|||
| 5 | +
- ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])+ #' Helper Function to create a new `SMQ` variable in `ADAE` that consists of all adverse events belonging to |
|||
| 387 | +6 |
- ) ++ #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events |
||
| 388 | -2x | +|||
| 7 | +
- ggplot2::geom_text(size = table_font_size) ++ #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing |
|||
| 389 | -2x | +|||
| 8 | +
- ggplot2::theme_bw() ++ #' done with [df_explicit_na()] to have the desired output. |
|||
| 390 | -2x | +|||
| 9 | +
- ggplot2::theme(+ #' |
|||
| 391 | -2x | +|||
| 10 | +
- panel.border = ggplot2::element_blank(),+ #' @inheritParams argument_convention |
|||
| 392 | -2x | +|||
| 11 | +
- panel.grid.major = ggplot2::element_blank(),+ #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries. |
|||
| 393 | -2x | +|||
| 12 | +
- panel.grid.minor = ggplot2::element_blank(),+ #' @param smq_varlabel (`string`)\cr a label for the new variable created. |
|||
| 394 | -2x | +|||
| 13 | +
- axis.ticks = ggplot2::element_blank(),+ #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created. |
|||
| 395 | -2x | +|||
| 14 | +
- axis.title = ggplot2::element_blank(),+ #' @param aag_summary (`data.frame`)\cr containing the `SMQ` baskets and the levels of interest for the final `SMQ` |
|||
| 396 | -2x | +|||
| 15 | +
- axis.text.x = ggplot2::element_blank(),+ #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset. |
|||
| 397 | -2x | +|||
| 16 | +
- axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)),+ #' The two columns of this dataset should be named `basket` and `basket_name`. |
|||
| 398 | -2x | +|||
| 17 | +
- strip.text = ggplot2::element_text(hjust = 0),+ #' |
|||
| 399 | -2x | +|||
| 18 | +
- strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")),+ #' @return `data.frame` with variables in `keys` taken from `df` and new variable `SMQ` containing |
|||
| 400 | -2x | +|||
| 19 | +
- strip.background = ggplot2::element_rect(fill = "grey95", color = NA),+ #' records belonging to the baskets selected via the `baskets` argument. |
|||
| 401 | -2x | +|||
| 20 | +
- legend.position = "none"+ #' |
|||
| 402 | +21 |
- )+ #' @examples |
||
| 403 | +22 |
-
+ #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na() |
||
| 404 | -2x | +|||
| 23 | +
- if (!is.null(group_var)) {
+ #' h_stack_by_baskets(df = adae) |
|||
| 405 | -2x | +|||
| 24 | +
- tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1)+ #' |
|||
| 406 | +25 |
- }+ #' aag <- data.frame( |
||
| 407 | +26 |
-
+ #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
|
||
| 408 | +27 |
- # align plot and table+ #' REFNAME = c( |
||
| 409 | -2x | +|||
| 28 | +
- cowplot::plot_grid(p, tbl, ncol = 1, align = "v", axis = "tblr")+ #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi", |
|||
| 410 | +29 |
- } else {
+ #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi" |
||
| 411 | -1x | +|||
| 30 | +
- p+ #' ), |
|||
| 412 | +31 |
- }+ #' SCOPE = c("", "", "BROAD", "BROAD"),
|
||
| 413 | +32 |
- }+ #' stringsAsFactors = FALSE |
||
| 414 | +33 |
-
+ #' ) |
||
| 415 | +34 |
- #' Helper function to get the right formatting in the optional table in `g_lineplot`.+ #' |
||
| 416 | +35 |
- #'+ #' basket_name <- character(nrow(aag)) |
||
| 417 | +36 |
- #' @description `r lifecycle::badge("stable")`
+ #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
|
||
| 418 | +37 |
- #'+ #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
|
||
| 419 | +38 |
- #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.+ #' basket_name[cq_pos] <- aag$REFNAME[cq_pos] |
||
| 420 | +39 |
- #' Elements of `x` must be `numeric` vectors.+ #' basket_name[smq_pos] <- paste0( |
||
| 421 | +40 |
- #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must+ #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
|
||
| 422 | +41 |
- #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell`+ #' ) |
||
| 423 | +42 |
- #' function through the `format` parameter.+ #' |
||
| 424 | +43 |
- #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must+ #' aag_summary <- data.frame( |
||
| 425 | +44 |
- #' match the names of `x`. When a label is not specified for an element of `x`,+ #' basket = aag$NAMVAR, |
||
| 426 | +45 |
- #' then this function tries to use `label` or `names` (in this order) attribute of that element+ #' basket_name = basket_name, |
||
| 427 | +46 |
- #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes+ #' stringsAsFactors = TRUE |
||
| 428 | +47 |
- #' are attached to a given element of `x`, then the label is automatically generated.+ #' ) |
||
| 429 | +48 |
#' |
||
| 430 | +49 |
- #' @return A single row `data.frame` object.+ #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary) |
||
| 431 | +50 | ++ |
+ #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ |
+ |
| 51 |
#' |
|||
| 432 | +52 |
- #' @examples+ #' h_stack_by_baskets( |
||
| 433 | +53 |
- #' mean_ci <- c(48, 51)+ #' df = adae, |
||
| 434 | +54 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ #' aag_summary = NULL, |
||
| 435 | +55 |
- #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")+ #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
|
||
| 436 | +56 |
- #' labels <- c(mean = "My Mean")+ #' baskets = "SMQ01NAM" |
||
| 437 | +57 |
- #' h_format_row(x, format, labels)+ #' ) |
||
| 438 | +58 |
#' |
||
| 439 | +59 |
- #' attr(mean_ci, "label") <- "Mean 95% CI"+ #' @export |
||
| 440 | +60 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ h_stack_by_baskets <- function(df, |
||
| 441 | +61 |
- #' h_format_row(x, format, labels)+ baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
|
||
| 442 | +62 |
- #'+ smq_varlabel = "Standardized MedDRA Query", |
||
| 443 | +63 |
- #' @export+ keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
|
||
| 444 | +64 |
- h_format_row <- function(x, format, labels = NULL) {
+ aag_summary = NULL, |
||
| 445 | +65 |
- # cell: one row, one column data.frame+ na_level = lifecycle::deprecated(), |
||
| 446 | -37x | +|||
| 66 | +
- format_cell <- function(x, format, label = NULL) {
+ na_str = "<Missing>") {
|
|||
| 447 | -110x | +67 | +5x |
- fc <- format_rcell(x = x, format = unlist(format))+ if (lifecycle::is_present(na_level)) {
|
| 448 | -110x | +|||
| 68 | +! |
- if (is.na(fc)) {
+ lifecycle::deprecate_warn("0.9.1", "h_stack_by_baskets(na_level)", "h_stack_by_baskets(na_str)")
|
||
| 449 | +69 | ! |
- fc <- "NA"+ na_str <- na_level |
|
| 450 | +70 |
- }+ }+ |
+ ||
| 71 | ++ | + | ||
| 451 | -110x | +72 | +5x |
- x_label <- attr(x, "label")+ smq_nam <- baskets[startsWith(baskets, "SMQ")]+ |
+
| 73 | ++ |
+ # SC corresponding to NAM |
||
| 452 | -110x | +74 | +5x |
- if (!is.null(label) && !is.na(label)) {
+ smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE) |
| 453 | -109x | +75 | +5x |
- names(fc) <- label+ smq <- stats::setNames(smq_sc, smq_nam)+ |
+
| 76 | ++ | + | ||
| 454 | -1x | +77 | +5x |
- } else if (!is.null(x_label) && !is.na(x_label)) {
+ checkmate::assert_character(baskets) |
| 455 | -! | +|||
| 78 | +5x |
- names(fc) <- x_label+ checkmate::assert_string(smq_varlabel) |
||
| 456 | -1x | +79 | +5x |
- } else if (length(x) == length(fc)) {
+ checkmate::assert_data_frame(df) |
| 457 | -! | +|||
| 80 | +5x |
- names(fc) <- names(x)+ checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ"))) |
||
| 458 | -+ | |||
| 81 | +4x |
- }+ checkmate::assert_true(all(endsWith(baskets, "NAM"))) |
||
| 459 | -110x | +82 | +3x |
- as.data.frame(t(fc))+ checkmate::assert_subset(baskets, names(df)) |
| 460 | -+ | |||
| 83 | +3x |
- }+ checkmate::assert_subset(keys, names(df))+ |
+ ||
| 84 | +3x | +
+ checkmate::assert_subset(smq_sc, names(df))+ |
+ ||
| 85 | +3x | +
+ checkmate::assert_string(na_str) |
||
| 461 | +86 | |||
| 462 | -37x | +87 | +3x |
- row <- do.call(+ if (!is.null(aag_summary)) {
|
| 463 | -37x | +88 | +1x |
- cbind,+ assert_df_with_variables( |
| 464 | -37x | +89 | +1x |
- lapply(+ df = aag_summary, |
| 465 | -37x | +90 | +1x |
- names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])+ variables = list(val = c("basket", "basket_name"))
|
| 466 | +91 |
) |
||
| 467 | +92 |
- )+ # Warning in case there is no match between `aag_summary$basket` and `baskets` argument. |
||
| 468 | +93 |
-
+ # Honestly, I think those should completely match. Target baskets should be the same. |
||
| 469 | -37x | +94 | +1x |
- row+ if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
|
| 470 | -+ | |||
| 95 | +! |
- }+ warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
|
||
| 471 | +96 |
-
+ } |
||
| 472 | +97 |
- #' Control Function for `g_lineplot` Function+ } |
||
| 473 | +98 |
- #'+ |
||
| 474 | -+ | |||
| 99 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel) |
||
| 475 | +100 |
- #'+ |
||
| 476 | +101 |
- #' Default values for `variables` parameter in `g_lineplot` function.+ # convert `na_str` records from baskets to NA for the later loop and from wide to long steps |
||
| 477 | -+ | |||
| 102 | +3x |
- #' A variable's default value can be overwritten for any variable.+ df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA |
||
| 478 | +103 |
- #'+ |
||
| 479 | -+ | |||
| 104 | +3x |
- #' @param x (`character`)\cr x variable name.+ if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
|
||
| 480 | -+ | |||
| 105 | +1x |
- #' @param y (`character`)\cr y variable name.+ df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty dataframe keeping all factor levels |
||
| 481 | +106 |
- #' @param group_var (`character` or `NA`)\cr group variable name.+ } else {
|
||
| 482 | +107 |
- #' @param strata (`character` or `NA`)\cr deprecated - group variable name.+ # Concatenate SMQxxxNAM with corresponding SMQxxxSC |
||
| 483 | -+ | |||
| 108 | +2x |
- #' @param subject_var (`character` or `NA`)\cr subject variable name.+ df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])] |
||
| 484 | +109 |
- #' @param cohort_id (`character` or `NA`)\cr deprecated - subject variable name.+ + |
+ ||
| 110 | +2x | +
+ for (nam in names(smq)) {
+ |
+ ||
| 111 | +4x | +
+ sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ |
+ ||
| 112 | +4x | +
+ nam_notna <- !is.na(df[[nam]])+ |
+ ||
| 113 | +4x | +
+ new_colname <- paste(nam, sc, sep = "_")+ |
+ ||
| 114 | +4x | +
+ df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
|
||
| 485 | +115 |
- #' @param paramcd (`character` or `NA`)\cr `paramcd` variable name.+ } |
||
| 486 | +116 |
- #' @param y_unit (`character` or `NA`)\cr `y_unit` variable name.+ + |
+ ||
| 117 | +2x | +
+ df_cnct$unique_id <- seq(1, nrow(df_cnct))+ |
+ ||
| 118 | +2x | +
+ var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))] |
||
| 487 | +119 |
- #'+ # have to convert df_cnct from tibble to dataframe |
||
| 488 | +120 |
- #' @return A named character vector of variable names.+ # as it throws a warning otherwise about rownames. |
||
| 489 | +121 |
- #'+ # tibble do not support rownames and reshape creates rownames |
||
| 490 | +122 |
- #' @examples+ + |
+ ||
| 123 | +2x | +
+ df_long <- stats::reshape(+ |
+ ||
| 124 | +2x | +
+ data = as.data.frame(df_cnct),+ |
+ ||
| 125 | +2x | +
+ varying = var_cols,+ |
+ ||
| 126 | +2x | +
+ v.names = "SMQ",+ |
+ ||
| 127 | +2x | +
+ idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ |
+ ||
| 128 | +2x | +
+ direction = "long",+ |
+ ||
| 129 | +2x | +
+ new.row.names = seq(prod(length(var_cols), nrow(df_cnct))) |
||
| 491 | +130 |
- #' control_lineplot_vars()+ ) |
||
| 492 | +131 |
- #' control_lineplot_vars(group_var = NA)+ + |
+ ||
| 132 | +2x | +
+ df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
+ |
+ ||
| 133 | +2x | +
+ df_long$SMQ <- as.factor(df_long$SMQ) |
||
| 493 | +134 |
- #'+ } |
||
| 494 | +135 |
- #' @export+ + |
+ ||
| 136 | +3x | +
+ smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str) |
||
| 495 | +137 |
- control_lineplot_vars <- function(x = "AVISIT", y = "AVAL", group_var = "ARM", paramcd = "PARAMCD", y_unit = "AVALU",+ + |
+ ||
| 138 | +3x | +
+ if (!is.null(aag_summary)) {
|
||
| 496 | +139 |
- subject_var = "USUBJID", strata = lifecycle::deprecated(),+ # A warning in case there is no match between df and aag_summary records+ |
+ ||
| 140 | +1x | +
+ if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
+ |
+ ||
| 141 | +1x | +
+ warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
|
||
| 497 | +142 |
- cohort_id = lifecycle::deprecated()) {
+ } |
||
| 498 | -3x | +143 | +1x |
- if (lifecycle::is_present(strata)) {
+ df_long[["SMQ"]] <- factor( |
| 499 | -! | +|||
| 144 | +1x |
- lifecycle::deprecate_warn("0.9.2", "control_lineplot_vars(strata)", "control_lineplot_vars(group_var)")
+ df_long[["SMQ"]], |
||
| 500 | -! | +|||
| 145 | +1x |
- group_var <- strata+ levels = sort( |
||
| 501 | -+ | |||
| 146 | +1x |
- }+ c( |
||
| 502 | -+ | |||
| 147 | +1x |
-
+ smq_levels, |
||
| 503 | -3x | +148 | +1x |
- if (lifecycle::is_present(cohort_id)) {
+ setdiff(unique(aag_summary$basket_name), smq_levels) |
| 504 | -! | +|||
| 149 | +
- lifecycle::deprecate_warn("0.9.2", "control_lineplot_vars(cohort_id)", "control_lineplot_vars(subject_id)")
+ ) |
|||
| 505 | -! | +|||
| 150 | +
- subject_id <- cohort_id+ ) |
|||
| 506 | +151 |
- }+ ) |
||
| 507 | +152 |
-
+ } else {
|
||
| 508 | -3x | +153 | +2x |
- checkmate::assert_string(x)+ all_na_basket_flag <- vapply(df[, baskets], function(x) {
|
| 509 | -3x | +154 | +6x |
- checkmate::assert_string(y)+ all(is.na(x)) |
| 510 | -3x | +155 | +2x |
- checkmate::assert_string(group_var, na.ok = TRUE)+ }, FUN.VALUE = logical(1)) |
| 511 | -3x | +156 | +2x |
- checkmate::assert_string(subject_var, na.ok = TRUE)+ all_na_basket <- baskets[all_na_basket_flag]+ |
+
| 157 | ++ | + | ||
| 512 | -3x | +158 | +2x |
- checkmate::assert_string(paramcd, na.ok = TRUE)+ df_long[["SMQ"]] <- factor( |
| 513 | -3x | +159 | +2x |
- checkmate::assert_string(y_unit, na.ok = TRUE)+ df_long[["SMQ"]],+ |
+
| 160 | +2x | +
+ levels = sort(c(smq_levels, all_na_basket)) |
||
| 514 | +161 |
-
+ )+ |
+ ||
| 162 | ++ |
+ } |
||
| 515 | +163 | 3x |
- variables <- c(x = x, y = y, group_var = group_var, paramcd = paramcd, y_unit = y_unit, subject_var = subject_var)+ formatters::var_labels(df_long) <- var_labels |
|
| 516 | +164 | 3x |
- return(variables)+ tibble::tibble(df_long) |
|
| 517 | +165 |
}@@ -109326,14 +110690,14 @@ tern coverage - 90.46% |
| 1 |
- #' Encode Categorical Missing Values in a Data Frame+ #' Helper Functions for Tabulating Binary Response by Subgroup |
||
| 5 |
- #' This is a helper function to encode missing entries across groups of categorical+ #' Helper functions that tabulate in a data frame statistics such as response rate |
||
| 6 |
- #' variables in a data frame.+ #' and odds ratio for population subgroups. |
||
| 8 |
- #' @details Missing entries are those with `NA` or empty strings and will+ #' @inheritParams argument_convention |
||
| 9 |
- #' be replaced with a specified value. If factor variables include missing+ #' @inheritParams response_subgroups |
||
| 10 |
- #' values, the missing value will be inserted as the last level.+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 11 |
- #' Similarly, in case character or logical variables should be converted to factors+ #' |
||
| 12 |
- #' with the `char_as_factor` or `logical_as_factor` options, the missing values will+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 13 |
- #' be set as the last level.+ #' |
||
| 14 |
- #'+ #' @examples |
||
| 15 |
- #' @param data (`data.frame`)\cr data set.+ #' library(dplyr) |
||
| 16 |
- #' @param omit_columns (`character`)\cr names of variables from `data` that should+ #' library(forcats) |
||
| 17 |
- #' not be modified by this function.+ #' |
||
| 18 |
- #' @param char_as_factor (`flag`)\cr whether to convert character variables+ #' adrs <- tern_ex_adrs |
||
| 19 |
- #' in `data` to factors.+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 20 |
- #' @param logical_as_factor (`flag`)\cr whether to convert logical variables+ #' |
||
| 21 |
- #' in `data` to factors.+ #' adrs_f <- adrs %>% |
||
| 22 |
- #' @param na_level (`string`)\cr used to replace all `NA` or empty+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 23 |
- #' values inside non-`omit_columns` columns.+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 24 |
- #'+ #' droplevels() %>% |
||
| 25 |
- #' @return A `data.frame` with the chosen modifications applied.+ #' mutate( |
||
| 26 |
- #'+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 27 |
- #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions.+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 28 |
- #'+ #' rsp = AVALC == "CR" |
||
| 29 |
- #' @examples+ #' ) |
||
| 30 |
- #' my_data <- data.frame(+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 31 |
- #' u = c(TRUE, FALSE, NA, TRUE),+ #' |
||
| 32 |
- #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
+ #' @name h_response_subgroups |
||
| 33 |
- #' w = c("A", "B", NA, "C"),
+ NULL |
||
| 34 |
- #' x = c("D", "E", "F", NA),
+
|
||
| 35 |
- #' y = c("G", "H", "I", ""),
+ #' @describeIn h_response_subgroups helper to prepare a data frame of binary responses by arm. |
||
| 36 |
- #' z = c(1, 2, 3, 4),+ #' |
||
| 37 |
- #' stringsAsFactors = FALSE+ #' @return |
||
| 38 |
- #' )+ #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`. |
||
| 40 |
- #' # Example 1+ #' @examples |
||
| 41 |
- #' # Encode missing values in all character or factor columns.+ #' h_proportion_df( |
||
| 42 |
- #' df_explicit_na(my_data)+ #' c(TRUE, FALSE, FALSE), |
||
| 43 |
- #' # Also convert logical columns to factor columns.+ #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
|
||
| 44 |
- #' df_explicit_na(my_data, logical_as_factor = TRUE)+ #' ) |
||
| 45 |
- #' # Encode missing values in a subset of columns.+ #' |
||
| 46 |
- #' df_explicit_na(my_data, omit_columns = c("x", "y"))
+ #' @export |
||
| 47 |
- #'+ h_proportion_df <- function(rsp, arm) {
|
||
| 48 | -+ | 64x |
- #' # Example 2+ checkmate::assert_logical(rsp) |
| 49 | -+ | 63x |
- #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable.+ assert_valid_factor(arm, len = length(rsp)) |
| 50 | -+ | 63x |
- #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not+ non_missing_rsp <- !is.na(rsp) |
| 51 | -+ | 63x |
- #' # included when generating `rtables`.+ rsp <- rsp[non_missing_rsp] |
| 52 | -+ | 63x |
- #' adsl <- tern_ex_adsl+ arm <- arm[non_missing_rsp] |
| 53 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ |
||
| 54 | -+ | 63x |
- #' adsl <- df_explicit_na(adsl)+ lst_rsp <- split(rsp, arm) |
| 55 | -+ | 63x |
- #'+ lst_results <- Map(function(x, arm) {
|
| 56 | -+ | 126x |
- #' # If you want the `Na` values to be displayed in the table use the `na_level` argument.+ if (length(x) > 0) {
|
| 57 | -+ | 124x |
- #' adsl <- tern_ex_adsl+ s_prop <- s_proportion(df = x) |
| 58 | -+ | 124x |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ data.frame( |
| 59 | -+ | 124x |
- #' adsl <- df_explicit_na(adsl, na_level = "Missing Values")+ arm = arm, |
| 60 | -+ | 124x |
- #'+ n = length(x), |
| 61 | -+ | 124x |
- #' # Example 3+ n_rsp = unname(s_prop$n_prop[1]), |
| 62 | -+ | 124x |
- #' # Numeric variables that have missing values are not altered. This means that any `NA` value in+ prop = unname(s_prop$n_prop[2]), |
| 63 | -+ | 124x |
- #' # a numeric variable will not be included in the summary statistics, nor will they be included+ stringsAsFactors = FALSE |
| 64 |
- #' # in the denominator value for calculating the percent values.+ ) |
||
| 65 |
- #' adsl <- tern_ex_adsl+ } else {
|
||
| 66 | -+ | 2x |
- #' adsl$AGE[adsl$AGE < 30] <- NA+ data.frame( |
| 67 | -+ | 2x |
- #' adsl <- df_explicit_na(adsl)+ arm = arm, |
| 68 | -+ | 2x |
- #'+ n = 0L, |
| 69 | -+ | 2x |
- #' @export+ n_rsp = NA, |
| 70 | -+ | 2x |
- df_explicit_na <- function(data,+ prop = NA, |
| 71 | -+ | 2x |
- omit_columns = NULL,+ stringsAsFactors = FALSE |
| 72 |
- char_as_factor = TRUE,+ ) |
||
| 73 |
- logical_as_factor = FALSE,+ } |
||
| 74 | -+ | 63x |
- na_level = "<Missing>") {
+ }, lst_rsp, names(lst_rsp)) |
| 75 | -21x | +
- checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)+ |
|
| 76 | -20x | +63x |
- checkmate::assert_data_frame(data)+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 77 | -19x | +63x |
- checkmate::assert_flag(char_as_factor)+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 78 | -18x | +63x |
- checkmate::assert_flag(logical_as_factor)+ df |
| 79 | -18x | +
- checkmate::assert_string(na_level)+ } |
|
| 81 | -16x | +
- target_vars <- if (is.null(omit_columns)) {
+ #' @describeIn h_response_subgroups summarizes proportion of binary responses by arm and across subgroups |
|
| 82 | -14x | +
- names(data)+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
|
| 83 |
- } else {
+ #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 84 | -2x | +
- setdiff(names(data), omit_columns) # May have duplicates.+ #' groupings for `subgroups` variables. |
|
| 85 |
- }+ #' |
||
| 86 | -16x | +
- if (length(target_vars) == 0) {
+ #' @return |
|
| 87 | -1x | +
- return(data)+ #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, |
|
| 88 |
- }+ #' `var`, `var_label`, and `row_type`. |
||
| 89 |
-
+ #' |
||
| 90 | -15x | +
- l_target_vars <- split(target_vars, target_vars)+ #' @examples |
|
| 91 |
-
+ #' h_proportion_subgroups_df( |
||
| 92 |
- # Makes sure target_vars exist in data and names are not duplicated.+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 93 | -15x | +
- assert_df_with_variables(data, l_target_vars)+ #' data = adrs_f |
|
| 94 |
-
+ #' ) |
||
| 95 | -15x | +
- for (x in target_vars) {
+ #' |
|
| 96 | -276x | +
- xi <- data[[x]]+ #' # Define groupings for BMRKR2 levels. |
|
| 97 | -276x | +
- xi_label <- obj_label(xi)+ #' h_proportion_subgroups_df( |
|
| 98 |
-
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 99 |
- # Determine whether to convert character or logical input.+ #' data = adrs_f, |
||
| 100 | -276x | +
- do_char_conversion <- is.character(xi) && char_as_factor+ #' groups_lists = list( |
|
| 101 | -276x | +
- do_logical_conversion <- is.logical(xi) && logical_as_factor+ #' BMRKR2 = list( |
|
| 102 |
-
+ #' "low" = "LOW", |
||
| 103 |
- # Pre-convert logical to character to deal correctly with replacing NA+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 104 |
- # values below.+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 105 | -276x | +
- if (do_logical_conversion) {
+ #' ) |
|
| 106 | -2x | +
- xi <- as.character(xi)+ #' ) |
|
| 107 |
- }+ #' ) |
||
| 108 |
-
+ #' |
||
| 109 | -276x | +
- if (is.factor(xi) || is.character(xi)) {
+ #' @export |
|
| 110 |
- # Handle empty strings and NA values.+ h_proportion_subgroups_df <- function(variables, |
||
| 111 | -198x | +
- xi <- explicit_na(sas_na(xi), label = na_level)+ data, |
|
| 112 |
-
+ groups_lists = list(), |
||
| 113 |
- # Convert to factors if requested for the original type,+ label_all = "All Patients") {
|
||
| 114 | -+ | 14x |
- # set na_level as the last value.+ checkmate::assert_character(variables$rsp) |
| 115 | -198x | +14x |
- if (do_char_conversion || do_logical_conversion) {
+ checkmate::assert_character(variables$arm) |
| 116 | -71x | +14x |
- levels_xi <- setdiff(sort(unique(xi)), na_level)+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 117 | -71x | +14x |
- if (na_level %in% unique(xi)) {
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 118 | -18x | +14x |
- levels_xi <- c(levels_xi, na_level)+ assert_df_with_variables(data, variables) |
| 119 | -+ | 14x |
- }+ checkmate::assert_string(label_all) |
| 121 | -71x | +
- xi <- factor(xi, levels = levels_xi)+ # Add All Patients. |
|
| 122 | -+ | 14x |
- }+ result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]]) |
| 123 | -+ | 14x |
-
+ result_all$subgroup <- label_all |
| 124 | -198x | +14x |
- data[, x] <- formatters::with_label(xi, label = xi_label)+ result_all$var <- "ALL" |
| 125 | -+ | 14x |
- }+ result_all$var_label <- label_all |
| 126 | -+ | 14x |
- }+ result_all$row_type <- "content" |
| 127 | -15x | +
- return(data)+ |
|
| 128 |
- }+ # Add Subgroups. |
| 1 | -+ | |||
| 129 | +14x |
- #' Count Patients with Marked Laboratory Abnormalities+ if (is.null(variables$subgroups)) {
+ |
+ ||
| 130 | +3x | +
+ result_all |
||
| 2 | +131 |
- #'+ } else {
+ |
+ ||
| 132 | +11x | +
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 3 | +133 |
- #' @description `r lifecycle::badge("stable")`
+
+ |
+ ||
| 134 | +11x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+ ||
| 135 | +46x | +
+ result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])+ |
+ ||
| 136 | +46x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+ ||
| 137 | +46x | +
+ cbind(result, result_labels) |
||
| 4 | +138 |
- #'+ })+ |
+ ||
| 139 | +11x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+ ||
| 140 | +11x | +
+ result_subgroups$row_type <- "analysis" |
||
| 5 | +141 |
- #' Primary analysis variable `.var` indicates whether single, replicated or last marked laboratory+ + |
+ ||
| 142 | +11x | +
+ rbind(+ |
+ ||
| 143 | +11x | +
+ result_all,+ |
+ ||
| 144 | +11x | +
+ result_subgroups |
||
| 6 | +145 |
- #' abnormality was observed (`factor`). Additional analysis variables are `id` (`character` or `factor`)+ ) |
||
| 7 | +146 |
- #' and `direction` (`factor`) indicating the direction of the abnormality. Denominator is number of+ } |
||
| 8 | +147 |
- #' patients with at least one valid measurement during the analysis.+ } |
||
| 9 | +148 |
- #' * For `Single, not last` and `Last or replicated`: Numerator is number of patients+ |
||
| 10 | +149 |
- #' with `Single, not last` and `Last or replicated` levels, respectively.+ #' @describeIn h_response_subgroups helper to prepare a data frame with estimates of |
||
| 11 | +150 |
- #' * For `Any`: Numerator is the number of patients with either single or+ #' the odds ratio between a treatment and a control arm. |
||
| 12 | +151 |
- #' replicated marked abnormalities.+ #' |
||
| 13 | +152 |
- #'+ #' @inheritParams response_subgroups |
||
| 14 | +153 |
- #' @inheritParams argument_convention+ #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed. |
||
| 15 | +154 |
- #' @param category (`list`)\cr with different marked category names for single+ #' |
||
| 16 | +155 |
- #' and last or replicated.+ #' @return |
||
| 17 | +156 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_marked")`
+ #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and |
||
| 18 | +157 |
- #' to see available statistics for this function.+ #' optionally `pval` and `pval_label`. |
||
| 19 | +158 |
#' |
||
| 20 | +159 |
- #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has+ #' @examples |
||
| 21 | +160 |
- #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the+ #' # Unstratatified analysis. |
||
| 22 | +161 |
- #' patient will be counted only under the `Last or replicated` category.+ #' h_odds_ratio_df( |
||
| 23 | +162 |
- #'+ #' c(TRUE, FALSE, FALSE, TRUE), |
||
| 24 | +163 |
- #' @name abnormal_by_marked+ #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 25 | +164 |
- #' @order 1+ #' ) |
||
| 26 | +165 |
- NULL+ #' |
||
| 27 | +166 |
-
+ #' # Include p-value. |
||
| 28 | +167 |
- #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities.+ #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq") |
||
| 29 | +168 |
#' |
||
| 30 | +169 |
- #' @return+ #' # Stratatified analysis. |
||
| 31 | +170 |
- #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`,+ #' h_odds_ratio_df( |
||
| 32 | +171 |
- #' `Last or replicated`, and `Any` results.+ #' rsp = adrs_f$rsp, |
||
| 33 | +172 |
- #'+ #' arm = adrs_f$ARM, |
||
| 34 | +173 |
- #' @keywords internal+ #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
|
||
| 35 | +174 |
- s_count_abnormal_by_marked <- function(df,+ #' method = "cmh" |
||
| 36 | +175 |
- .var = "AVALCAT1",+ #' ) |
||
| 37 | +176 |
- .spl_context,+ #' |
||
| 38 | +177 |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ #' @export |
||
| 39 | +178 |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
+ h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
|
||
| 40 | -3x | +179 | +69x |
- checkmate::assert_string(.var)+ assert_valid_factor(arm, n.levels = 2, len = length(rsp)) |
| 41 | -3x | +|||
| 180 | +
- checkmate::assert_list(variables)+ |
|||
| 42 | -3x | +181 | +69x |
- checkmate::assert_list(category)+ df_rsp <- data.frame( |
| 43 | -3x | +182 | +69x |
- checkmate::assert_subset(names(category), c("single", "last_replicated"))
+ rsp = rsp, |
| 44 | -3x | +183 | +69x |
- checkmate::assert_subset(names(variables), c("id", "param", "direction"))
+ arm = arm |
| 45 | -3x | +|||
| 184 | +
- checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)+ ) |
|||
| 46 | +185 | |||
| 47 | -2x | +186 | +69x |
- assert_df_with_variables(df, c(aval = .var, variables))+ if (!is.null(strata_data)) {
|
| 48 | -2x | +187 | +11x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ strata_var <- interaction(strata_data, drop = TRUE) |
| 49 | -2x | +188 | +11x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ strata_name <- "strata" |
| 50 | +189 | |||
| 190 | +11x | +
+ assert_valid_factor(strata_var, len = nrow(df_rsp))+ |
+ ||
| 51 | +191 | |||
| 52 | -2x | +192 | +11x |
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ df_rsp[[strata_name]] <- strata_var |
| 53 | +193 |
- # Patients in the denominator have at least one post-baseline visit.+ } else {
|
||
| 54 | -2x | +194 | +58x |
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ strata_name <- NULL |
| 55 | -2x | +|||
| 195 | +
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ } |
|||
| 56 | +196 |
- # Some subjects may have a record for high and low directions but+ + |
+ ||
| 197 | +69x | +
+ l_df <- split(df_rsp, arm) |
||
| 57 | +198 |
- # should be counted only once.+ |
||
| 58 | -2x | +199 | +69x |
- denom <- length(unique(subj_cur_col))+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
| 59 | +200 |
-
+ # Odds ratio and CI. |
||
| 60 | -2x | +201 | +67x |
- if (denom != 0) {
+ result_odds_ratio <- s_odds_ratio( |
| 61 | -2x | +202 | +67x |
- subjects_last_replicated <- unique(+ df = l_df[[2]], |
| 62 | -2x | +203 | +67x |
- df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]+ .var = "rsp",+ |
+
| 204 | +67x | +
+ .ref_group = l_df[[1]],+ |
+ ||
| 205 | +67x | +
+ .in_ref_col = FALSE,+ |
+ ||
| 206 | +67x | +
+ .df_row = df_rsp,+ |
+ ||
| 207 | +67x | +
+ variables = list(arm = "arm", strata = strata_name),+ |
+ ||
| 208 | +67x | +
+ conf_level = conf_level |
||
| 63 | +209 |
) |
||
| 210 | ++ | + + | +||
| 64 | -2x | +211 | +67x |
- subjects_single <- unique(+ df <- data.frame(+ |
+
| 212 | ++ |
+ # Dummy column needed downstream to create a nested header. |
||
| 65 | -2x | +213 | +67x |
- df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]+ arm = " ",+ |
+
| 214 | +67x | +
+ n_tot = unname(result_odds_ratio$n_tot["n_tot"]),+ |
+ ||
| 215 | +67x | +
+ or = unname(result_odds_ratio$or_ci["est"]),+ |
+ ||
| 216 | +67x | +
+ lcl = unname(result_odds_ratio$or_ci["lcl"]),+ |
+ ||
| 217 | +67x | +
+ ucl = unname(result_odds_ratio$or_ci["ucl"]),+ |
+ ||
| 218 | +67x | +
+ conf_level = conf_level,+ |
+ ||
| 219 | +67x | +
+ stringsAsFactors = FALSE |
||
| 66 | +220 |
) |
||
| 67 | +221 |
- # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.+ |
||
| 68 | -2x | +222 | +67x |
- subjects_single <- setdiff(subjects_single, subjects_last_replicated)+ if (!is.null(method)) {
+ |
+
| 223 | ++ |
+ # Test for difference. |
||
| 69 | -2x | +224 | +34x |
- n_single <- length(subjects_single)+ result_test <- s_test_proportion_diff( |
| 70 | -2x | +225 | +34x |
- n_last_replicated <- length(subjects_last_replicated)+ df = l_df[[2]], |
| 71 | -2x | +226 | +34x |
- n_any <- n_single + n_last_replicated+ .var = "rsp", |
| 72 | -2x | +227 | +34x |
- result <- list(count_fraction = list(+ .ref_group = l_df[[1]], |
| 73 | -2x | +228 | +34x |
- "Single, not last" = c(n_single, n_single / denom),+ .in_ref_col = FALSE, |
| 74 | -2x | +229 | +34x |
- "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),+ variables = list(strata = strata_name), |
| 75 | -2x | +230 | +34x |
- "Any Abnormality" = c(n_any, n_any / denom)+ method = method |
| 76 | +231 |
- ))+ ) |
||
| 77 | +232 |
- } else {
+
|
||
| 78 | -! | +|||
| 233 | +34x |
- result <- list(count_fraction = list(+ df$pval <- as.numeric(result_test$pval) |
||
| 79 | -! | +|||
| 234 | +34x |
- "Single, not last" = c(0, 0),+ df$pval_label <- obj_label(result_test$pval) |
||
| 80 | -! | +|||
| 235 | +
- "Last or replicated" = c(0, 0),+ }+ |
+ |||
| 236 | ++ | + + | +||
| 237 | ++ |
+ # In those cases cannot go through the model so will obtain n_tot from data.+ |
+ ||
| 238 | ++ |
+ } else if (+ |
+ ||
| 239 | +2x | +
+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ |
+ ||
| 240 | +2x | +
+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ |
+ ||
| 241 | ++ |
+ ) {
|
||
| 81 | -! | +|||
| 242 | +2x |
- "Any Abnormality" = c(0, 0)+ df <- data.frame( |
||
| 82 | +243 |
- ))+ # Dummy column needed downstream to create a nested header. |
||
| 83 | -+ | |||
| 244 | +2x |
- }+ arm = " ", |
||
| 84 | -+ | |||
| 245 | +2x |
-
+ n_tot = sum(stats::complete.cases(df_rsp)), |
||
| 85 | +246 | 2x |
- result+ or = NA, |
|
| 86 | -+ | |||
| 247 | +2x |
- }+ lcl = NA, |
||
| 87 | -+ | |||
| 248 | +2x |
-
+ ucl = NA, |
||
| 88 | -+ | |||
| 249 | +2x |
- #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun`+ conf_level = conf_level, |
||
| 89 | -+ | |||
| 250 | +2x |
- #' in `count_abnormal_by_marked()`.+ stringsAsFactors = FALSE |
||
| 90 | +251 |
- #'+ ) |
||
| 91 | -+ | |||
| 252 | +2x |
- #' @return+ if (!is.null(method)) {
|
||
| 92 | -+ | |||
| 253 | +2x |
- #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()].+ df$pval <- NA |
||
| 93 | -+ | |||
| 254 | +2x |
- #'+ df$pval_label <- NA |
||
| 94 | +255 |
- #' @keywords internal+ } |
||
| 95 | +256 |
- a_count_abnormal_by_marked <- make_afun(+ } else {
|
||
| 96 | -+ | |||
| 257 | +! |
- s_count_abnormal_by_marked,+ df <- data.frame( |
||
| 97 | +258 |
- .formats = c(count_fraction = format_count_fraction)+ # Dummy column needed downstream to create a nested header. |
||
| 98 | -+ | |||
| 259 | +! |
- )+ arm = " ", |
||
| 99 | -+ | |||
| 260 | +! |
-
+ n_tot = 0L, |
||
| 100 | -+ | |||
| 261 | +! |
- #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments+ or = NA, |
||
| 101 | -+ | |||
| 262 | +! |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ lcl = NA, |
||
| 102 | -+ | |||
| 263 | +! |
- #'+ ucl = NA, |
||
| 103 | -+ | |||
| 264 | +! |
- #' @return+ conf_level = conf_level, |
||
| 104 | -+ | |||
| 265 | +! |
- #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions,+ stringsAsFactors = FALSE |
||
| 105 | +266 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ ) |
||
| 106 | +267 |
- #' the statistics from `s_count_abnormal_by_marked()` to the table layout.+ |
||
| 107 | -+ | |||
| 268 | +! |
- #'+ if (!is.null(method)) {
|
||
| 108 | -+ | |||
| 269 | +! |
- #' @examples+ df$pval <- NA |
||
| 109 | -+ | |||
| 270 | +! |
- #' library(dplyr)+ df$pval_label <- NA |
||
| 110 | +271 |
- #'+ } |
||
| 111 | +272 |
- #' df <- data.frame(+ } |
||
| 112 | +273 |
- #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),+ |
||
| 113 | -+ | |||
| 274 | +69x |
- #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
+ df |
||
| 114 | +275 |
- #' ANRIND = factor(c(+ } |
||
| 115 | +276 |
- #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",+ |
||
| 116 | +277 |
- #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",+ #' @describeIn h_response_subgroups summarizes estimates of the odds ratio between a treatment and a control |
||
| 117 | +278 |
- #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"+ #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in |
||
| 118 | +279 |
- #' )),+ #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups` |
||
| 119 | +280 |
- #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
+ #' and `strata`. `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 120 | +281 |
- #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
+ #' |
||
| 121 | +282 |
- #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
+ #' @return |
||
| 122 | +283 |
- #' stringsAsFactors = FALSE+ #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, |
||
| 123 | +284 |
- #' )+ #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 124 | +285 |
#' |
||
| 125 | +286 |
- #' df <- df %>%+ #' @examples |
||
| 126 | +287 |
- #' mutate(abn_dir = factor(+ #' # Unstratified analysis. |
||
| 127 | +288 |
- #' case_when(+ #' h_odds_ratio_subgroups_df( |
||
| 128 | +289 |
- #' ANRIND == "LOW LOW" ~ "Low",+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 129 | +290 |
- #' ANRIND == "HIGH HIGH" ~ "High",+ #' data = adrs_f |
||
| 130 | +291 |
- #' TRUE ~ ""+ #' ) |
||
| 131 | +292 |
- #' ),+ #' |
||
| 132 | +293 |
- #' levels = c("Low", "High")
+ #' # Stratified analysis. |
||
| 133 | +294 |
- #' ))+ #' h_odds_ratio_subgroups_df( |
||
| 134 | +295 |
- #'+ #' variables = list( |
||
| 135 | +296 |
- #' # Select only post-baseline records.+ #' rsp = "rsp", |
||
| 136 | +297 |
- #' df <- df %>% filter(ONTRTFL == "Y")+ #' arm = "ARM", |
||
| 137 | +298 |
- #' df_crp <- df %>%+ #' subgroups = c("SEX", "BMRKR2"),
|
||
| 138 | +299 |
- #' filter(PARAMCD == "CRP") %>%+ #' strata = c("STRATA1", "STRATA2")
|
||
| 139 | +300 |
- #' droplevels()+ #' ), |
||
| 140 | +301 |
- #' full_parent_df <- list(df_crp, "not_needed")+ #' data = adrs_f |
||
| 141 | +302 |
- #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")+ #' ) |
||
| 142 | +303 |
- #' spl_context <- data.frame(+ #' |
||
| 143 | +304 |
- #' split = c("PARAMCD", "GRADE_DIR"),
+ #' # Define groupings of BMRKR2 levels. |
||
| 144 | +305 |
- #' full_parent_df = I(full_parent_df),+ #' h_odds_ratio_subgroups_df( |
||
| 145 | +306 |
- #' cur_col_subset = I(cur_col_subset)+ #' variables = list( |
||
| 146 | +307 |
- #' )+ #' rsp = "rsp", |
||
| 147 | +308 |
- #'+ #' arm = "ARM", |
||
| 148 | +309 |
- #' map <- unique(+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 149 | +310 |
- #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
+ #' ), |
||
| 150 | +311 |
- #' ) %>%+ #' data = adrs_f, |
||
| 151 | +312 |
- #' lapply(as.character) %>%+ #' groups_lists = list( |
||
| 152 | +313 |
- #' as.data.frame() %>%+ #' BMRKR2 = list( |
||
| 153 | +314 |
- #' arrange(PARAMCD, abn_dir)+ #' "low" = "LOW", |
||
| 154 | +315 |
- #'+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 155 | +316 |
- #' basic_table() %>%+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 156 | +317 |
- #' split_cols_by("ARMCD") %>%
+ #' ) |
||
| 157 | +318 |
- #' split_rows_by("PARAMCD") %>%
+ #' ) |
||
| 158 | +319 |
- #' summarize_num_patients(+ #' ) |
||
| 159 | +320 |
- #' var = "USUBJID",+ #' |
||
| 160 | +321 |
- #' .stats = "unique_count"+ #' @export |
||
| 161 | +322 |
- #' ) %>%+ h_odds_ratio_subgroups_df <- function(variables, |
||
| 162 | +323 |
- #' split_rows_by(+ data, |
||
| 163 | +324 |
- #' "abn_dir",+ groups_lists = list(), |
||
| 164 | +325 |
- #' split_fun = trim_levels_to_map(map)+ conf_level = 0.95, |
||
| 165 | +326 |
- #' ) %>%+ method = NULL, |
||
| 166 | +327 |
- #' count_abnormal_by_marked(+ label_all = "All Patients") {
|
||
| 167 | -+ | |||
| 328 | +15x |
- #' var = "AVALCAT1",+ if ("strat" %in% names(variables)) {
|
||
| 168 | -+ | |||
| 329 | +! |
- #' variables = list(+ warning( |
||
| 169 | -+ | |||
| 330 | +! |
- #' id = "USUBJID",+ "Warning: the `strat` element name of the `variables` list argument to `h_odds_ratio_subgroups_df() ", |
||
| 170 | -+ | |||
| 331 | +! |
- #' param = "PARAMCD",+ "was deprecated in tern 0.9.3.\n ", |
||
| 171 | -+ | |||
| 332 | +! |
- #' direction = "abn_dir"+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 172 | +333 |
- #' )+ ) |
||
| 173 | -+ | |||
| 334 | +! |
- #' ) %>%+ variables[["strata"]] <- variables[["strat"]] |
||
| 174 | +335 |
- #' build_table(df = df)+ } |
||
| 175 | +336 |
- #'+ |
||
| 176 | -+ | |||
| 337 | +15x |
- #' basic_table() %>%+ checkmate::assert_character(variables$rsp) |
||
| 177 | -+ | |||
| 338 | +15x |
- #' split_cols_by("ARMCD") %>%
+ checkmate::assert_character(variables$arm) |
||
| 178 | -+ | |||
| 339 | +15x |
- #' split_rows_by("PARAMCD") %>%
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 179 | -+ | |||
| 340 | +15x |
- #' summarize_num_patients(+ checkmate::assert_character(variables$strata, null.ok = TRUE) |
||
| 180 | -+ | |||
| 341 | +15x |
- #' var = "USUBJID",+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
||
| 181 | -+ | |||
| 342 | +15x |
- #' .stats = "unique_count"+ assert_df_with_variables(data, variables) |
||
| 182 | -+ | |||
| 343 | +15x |
- #' ) %>%+ checkmate::assert_string(label_all) |
||
| 183 | +344 |
- #' split_rows_by(+ |
||
| 184 | -+ | |||
| 345 | +15x |
- #' "abn_dir",+ strata_data <- if (is.null(variables$strata)) {
|
||
| 185 | -+ | |||
| 346 | +13x |
- #' split_fun = trim_levels_in_group("abn_dir")
+ NULL |
||
| 186 | +347 |
- #' ) %>%+ } else {
|
||
| 187 | -+ | |||
| 348 | +2x |
- #' count_abnormal_by_marked(+ data[, variables$strata, drop = FALSE] |
||
| 188 | +349 |
- #' var = "AVALCAT1",+ } |
||
| 189 | +350 |
- #' variables = list(+ |
||
| 190 | +351 |
- #' id = "USUBJID",+ # Add All Patients. |
||
| 191 | -+ | |||
| 352 | +15x |
- #' param = "PARAMCD",+ result_all <- h_odds_ratio_df( |
||
| 192 | -+ | |||
| 353 | +15x |
- #' direction = "abn_dir"+ rsp = data[[variables$rsp]], |
||
| 193 | -+ | |||
| 354 | +15x |
- #' )+ arm = data[[variables$arm]], |
||
| 194 | -+ | |||
| 355 | +15x |
- #' ) %>%+ strata_data = strata_data, |
||
| 195 | -+ | |||
| 356 | +15x |
- #' build_table(df = df)+ conf_level = conf_level, |
||
| 196 | -+ | |||
| 357 | +15x |
- #'+ method = method |
||
| 197 | +358 |
- #' @export+ ) |
||
| 198 | -+ | |||
| 359 | +15x |
- #' @order 2+ result_all$subgroup <- label_all |
||
| 199 | -+ | |||
| 360 | +15x |
- count_abnormal_by_marked <- function(lyt,+ result_all$var <- "ALL" |
||
| 200 | -+ | |||
| 361 | +15x |
- var,+ result_all$var_label <- label_all |
||
| 201 | -+ | |||
| 362 | +15x |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ result_all$row_type <- "content" |
||
| 202 | +363 |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"),+ |
||
| 203 | -+ | |||
| 364 | +15x |
- na_str = default_na_str(),+ if (is.null(variables$subgroups)) {
|
||
| 204 | -+ | |||
| 365 | +3x |
- nested = TRUE,+ result_all |
||
| 205 | +366 |
- ...,+ } else {
|
||
| 206 | -+ | |||
| 367 | +12x |
- .stats = NULL,+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 207 | +368 |
- .formats = NULL,+ |
||
| 208 | -+ | |||
| 369 | +12x |
- .labels = NULL,+ l_result <- lapply(l_data, function(grp) {
|
||
| 209 | -+ | |||
| 370 | +50x |
- .indent_mods = NULL) {
+ grp_strata_data <- if (is.null(variables$strata)) {
|
||
| 210 | -1x | +371 | +42x |
- checkmate::assert_string(var)+ NULL |
| 211 | +372 |
-
+ } else {
|
||
| 212 | -1x | +373 | +8x |
- extra_args <- list(category = category, variables = variables, ...)+ grp$df[, variables$strata, drop = FALSE] |
| 213 | +374 |
-
+ } |
||
| 214 | -1x | +|||
| 375 | +
- afun <- make_afun(+ |
|||
| 215 | -1x | +376 | +50x |
- a_count_abnormal_by_marked,+ result <- h_odds_ratio_df( |
| 216 | -1x | +377 | +50x |
- .stats = .stats,+ rsp = grp$df[[variables$rsp]], |
| 217 | -1x | +378 | +50x |
- .formats = .formats,+ arm = grp$df[[variables$arm]], |
| 218 | -1x | +379 | +50x |
- .labels = .labels,+ strata_data = grp_strata_data, |
| 219 | -1x | +380 | +50x |
- .indent_mods = .indent_mods,+ conf_level = conf_level, |
| 220 | -1x | +381 | +50x |
- .ungroup_stats = "count_fraction"+ method = method |
| 221 | +382 |
- )+ ) |
||
| 222 | -+ | |||
| 383 | +50x |
-
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
||
| 223 | -1x | +384 | +50x |
- lyt <- analyze(+ cbind(result, result_labels) |
| 224 | -1x | +|||
| 385 | +
- lyt = lyt,+ }) |
|||
| 225 | -1x | +|||
| 386 | +
- vars = var,+ |
|||
| 226 | -1x | +387 | +12x |
- afun = afun,+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 227 | -1x | +388 | +12x |
- na_str = na_str,+ result_subgroups$row_type <- "analysis"+ |
+
| 389 | ++ | + | ||
| 228 | -1x | +390 | +12x |
- nested = nested,+ rbind( |
| 229 | -1x | +391 | +12x |
- show_labels = "hidden",+ result_all, |
| 230 | -1x | +392 | +12x |
- extra_args = extra_args+ result_subgroups |
| 231 | +393 |
- )+ ) |
||
| 232 | -1x | +|||
| 394 | +
- lyt+ } |
|||
| 233 | +395 |
}@@ -111865,14 +113461,14 @@ tern coverage - 90.46% |
| 1 |
- #' Stack Multiple Grobs+ #' Add Titles, Footnotes, Page Number, and a Bounding Box to a Grid Grob |
||
| 5 |
- #' Stack grobs as a new grob with 1 column and multiple rows layout.+ #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots) |
||
| 6 |
- #'+ #' with title, footnote, and page numbers. |
||
| 7 |
- #' @param ... grobs.+ #' |
||
| 8 |
- #' @param grobs list of grobs.+ #' @inheritParams grid::grob |
||
| 9 |
- #' @param padding unit of length 1, space between each grob.+ #' @param grob a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown. |
||
| 10 |
- #' @param vp a [viewport()] object (or `NULL`).+ #' @param titles vector of character strings. Vector elements are separated by a newline and strings are wrapped |
||
| 11 |
- #' @param name a character identifier for the grob.+ #' according to the page width. |
||
| 12 |
- #' @param gp A [gpar()] object.+ #' @param footnotes vector of character string. Same rules as for `titles`. |
||
| 13 |
- #'+ #' @param page string with page numeration, if `NULL` then no page number is displayed. |
||
| 14 |
- #' @return A `grob`.+ #' @param width_titles unit object |
||
| 15 |
- #'+ #' @param width_footnotes unit object |
||
| 16 |
- #' @examples+ #' @param border boolean, whether a a border should be drawn around the plot or not. |
||
| 17 |
- #' library(grid)+ #' @param margins unit object of length 4 |
||
| 18 |
- #'+ #' @param padding unit object of length 4 |
||
| 19 |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ #' @param outer_margins unit object of length 4 |
||
| 20 |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ #' @param gp_titles a `gpar` object |
||
| 21 |
- #' g3 <- textGrob("TEST TEXT")
+ #' @param gp_footnotes a `gpar` object |
||
| 22 |
- #' grid.newpage()+ #' |
||
| 23 |
- #' grid.draw(stack_grobs(g1, g2, g3))+ #' @return A grid grob (`gTree`). |
||
| 25 |
- #' showViewport()+ #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually. |
||
| 27 |
- #' grid.newpage()+ #' @examples |
||
| 28 |
- #' pushViewport(viewport(layout = grid.layout(1, 2)))+ #' library(grid) |
||
| 29 |
- #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)+ #' |
||
| 30 |
- #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))+ #' titles <- c( |
||
| 31 |
- #'+ #' "Edgar Anderson's Iris Data", |
||
| 32 |
- #' showViewport()+ #' paste( |
||
| 33 |
- #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)+ #' "This famous (Fisher's or Anderson's) iris data set gives the measurements", |
||
| 34 |
- #'+ #' "in centimeters of the variables sepal length and width and petal length", |
||
| 35 |
- #' @export+ #' "and width, respectively, for 50 flowers from each of 3 species of iris." |
||
| 36 |
- stack_grobs <- function(...,+ #' ) |
||
| 37 |
- grobs = list(...),+ #' ) |
||
| 38 |
- padding = grid::unit(2, "line"),+ #' |
||
| 39 |
- vp = NULL,+ #' footnotes <- c( |
||
| 40 |
- gp = NULL,+ #' "The species are Iris setosa, versicolor, and virginica.", |
||
| 41 |
- name = NULL) {
+ #' paste( |
||
| 42 | -4x | +
- checkmate::assert_true(+ #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named", |
|
| 43 | -4x | +
- all(vapply(grobs, grid::is.grob, logical(1)))+ #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species." |
|
| 44 |
- )+ #' ) |
||
| 45 |
-
+ #' ) |
||
| 46 | -4x | +
- if (length(grobs) == 1) {
+ #' |
|
| 47 | -1x | +
- return(grobs[[1]])+ #' ## empty plot |
|
| 48 |
- }+ #' grid.newpage() |
||
| 49 |
-
+ #' |
||
| 50 | -3x | +
- n_layout <- 2 * length(grobs) - 1+ #' grid.draw( |
|
| 51 | -3x | +
- hts <- lapply(+ #' decorate_grob( |
|
| 52 | -3x | +
- seq(1, n_layout),+ #' NULL, |
|
| 53 | -3x | +
- function(i) {
+ #' titles = titles, |
|
| 54 | -39x | +
- if (i %% 2 != 0) {
+ #' footnotes = footnotes, |
|
| 55 | -21x | +
- grid::unit(1, "null")+ #' page = "Page 4 of 10" |
|
| 56 |
- } else {
+ #' ) |
||
| 57 | -18x | +
- padding+ #' ) |
|
| 58 |
- }+ #' |
||
| 59 |
- }+ #' # grid |
||
| 60 |
- )+ #' p <- gTree( |
||
| 61 | -3x | +
- hts <- do.call(grid::unit.c, hts)+ #' children = gList( |
|
| 62 |
-
+ #' rectGrob(), |
||
| 63 | -3x | +
- main_vp <- grid::viewport(+ #' xaxisGrob(), |
|
| 64 | -3x | +
- layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)+ #' yaxisGrob(), |
|
| 65 |
- )+ #' textGrob("Sepal.Length", y = unit(-4, "lines")),
|
||
| 66 |
-
+ #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
|
||
| 67 | -3x | +
- nested_grobs <- Map(function(g, i) {
+ #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16) |
|
| 68 | -21x | +
- grid::gTree(+ #' ), |
|
| 69 | -21x | +
- children = grid::gList(g),+ #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length)) |
|
| 70 | -21x | +
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)+ #' ) |
|
| 71 |
- )+ #' grid.newpage() |
||
| 72 | -3x | +
- }, grobs, seq_along(grobs) * 2 - 1)+ #' grid.draw(p) |
|
| 73 |
-
+ #' |
||
| 74 | -3x | +
- grobs_mainvp <- grid::gTree(+ #' grid.newpage() |
|
| 75 | -3x | +
- children = do.call(grid::gList, nested_grobs),+ #' grid.draw( |
|
| 76 | -3x | +
- vp = main_vp+ #' decorate_grob( |
|
| 77 |
- )+ #' grob = p, |
||
| 78 |
-
+ #' titles = titles, |
||
| 79 | -3x | +
- grid::gTree(+ #' footnotes = footnotes, |
|
| 80 | -3x | +
- children = grid::gList(grobs_mainvp),+ #' page = "Page 6 of 129" |
|
| 81 | -3x | +
- vp = vp,+ #' ) |
|
| 82 | -3x | +
- gp = gp,+ #' ) |
|
| 83 | -3x | +
- name = name+ #' |
|
| 84 |
- )+ #' ## with ggplot2 |
||
| 85 |
- }+ #' library(ggplot2) |
||
| 86 |
-
+ #' |
||
| 87 |
- #' Arrange Multiple Grobs+ #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 88 |
- #'+ #' ggplot2::geom_point() |
||
| 89 |
- #' Arrange grobs as a new grob with \verb{n*m (rows*cols)} layout.
+ #' p_gg |
||
| 90 |
- #'+ #' p <- ggplotGrob(p_gg) |
||
| 91 |
- #' @inheritParams stack_grobs+ #' grid.newpage() |
||
| 92 |
- #' @param ncol number of columns in layout.+ #' grid.draw( |
||
| 93 |
- #' @param nrow number of rows in layout.+ #' decorate_grob( |
||
| 94 |
- #' @param padding_ht unit of length 1, vertical space between each grob.+ #' grob = p, |
||
| 95 |
- #' @param padding_wt unit of length 1, horizontal space between each grob.+ #' titles = titles, |
||
| 96 |
- #'+ #' footnotes = footnotes, |
||
| 97 |
- #' @return A `grob`.+ #' page = "Page 6 of 129" |
||
| 98 |
- #' @examples+ #' ) |
||
| 99 |
- #' library(grid)+ #' ) |
||
| 101 |
- #' \donttest{
+ #' ## with lattice |
||
| 102 |
- #' num <- lapply(1:9, textGrob)+ #' library(lattice) |
||
| 103 |
- #' grid::grid.newpage()+ #' |
||
| 104 |
- #' grid.draw(arrange_grobs(grobs = num, ncol = 2))+ #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species) |
||
| 105 |
- #'+ #' p <- grid.grab() |
||
| 106 |
- #' showViewport()+ #' grid.newpage() |
||
| 107 |
- #'+ #' grid.draw( |
||
| 108 |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ #' decorate_grob( |
||
| 109 |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ #' grob = p, |
||
| 110 |
- #' g3 <- textGrob("TEST TEXT")
+ #' titles = titles, |
||
| 111 |
- #' grid::grid.newpage()+ #' footnotes = footnotes, |
||
| 112 |
- #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))+ #' page = "Page 6 of 129" |
||
| 113 |
- #'+ #' ) |
||
| 114 |
- #' showViewport()+ #' ) |
||
| 116 |
- #' grid::grid.newpage()+ #' # with gridExtra - no borders |
||
| 117 |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))+ #' library(gridExtra) |
||
| 118 |
- #'+ #' grid.newpage() |
||
| 119 |
- #' grid::grid.newpage()+ #' grid.draw( |
||
| 120 |
- #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))+ #' decorate_grob( |
||
| 121 |
- #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)+ #' tableGrob( |
||
| 122 |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))+ #' head(mtcars) |
||
| 123 |
- #'+ #' ), |
||
| 124 |
- #' showViewport()+ #' titles = "title", |
||
| 125 |
- #' }+ #' footnotes = "footnote", |
||
| 126 |
- #' @export+ #' border = FALSE |
||
| 127 |
- arrange_grobs <- function(...,+ #' ) |
||
| 128 |
- grobs = list(...),+ #' ) |
||
| 129 |
- ncol = NULL, nrow = NULL,+ #' |
||
| 130 |
- padding_ht = grid::unit(2, "line"),+ #' @export |
||
| 131 |
- padding_wt = grid::unit(2, "line"),+ decorate_grob <- function(grob, |
||
| 132 |
- vp = NULL,+ titles, |
||
| 133 |
- gp = NULL,+ footnotes, |
||
| 134 |
- name = NULL) {
+ page = "", |
||
| 135 | -5x | +
- checkmate::assert_true(+ width_titles = grid::unit(1, "npc") - grid::unit(1.5, "cm"), |
|
| 136 | -5x | +
- all(vapply(grobs, grid::is.grob, logical(1)))+ width_footnotes = grid::unit(1, "npc") - grid::unit(1.5, "cm"), |
|
| 137 |
- )+ border = TRUE, |
||
| 138 |
-
+ margins = grid::unit(c(1, 0, 1, 0), "lines"), |
||
| 139 | -5x | +
- if (length(grobs) == 1) {
+ padding = grid::unit(rep(1, 4), "lines"), |
|
| 140 | -1x | +
- return(grobs[[1]])+ outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"), |
|
| 141 |
- }+ gp_titles = grid::gpar(), |
||
| 142 |
-
+ gp_footnotes = grid::gpar(fontsize = 8), |
||
| 143 | -4x | +
- if (is.null(ncol) && is.null(nrow)) {
+ name = NULL, |
|
| 144 | -1x | +
- ncol <- 1+ gp = grid::gpar(), |
|
| 145 | -1x | +
- nrow <- ceiling(length(grobs) / ncol)+ vp = NULL) {
|
|
| 146 | -3x | +9x |
- } else if (!is.null(ncol) && is.null(nrow)) {
+ st_titles <- split_text_grob( |
| 147 | -1x | +9x |
- nrow <- ceiling(length(grobs) / ncol)+ titles, |
| 148 | -2x | +9x |
- } else if (is.null(ncol) && !is.null(nrow)) {
+ x = 0, y = 1, |
| 149 | -! | +9x |
- ncol <- ceiling(length(grobs) / nrow)+ just = c("left", "top"),
|
| 150 | -+ | 9x |
- }+ width = width_titles, |
| 151 | -+ | 9x |
-
+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1), |
| 152 | -4x | +9x |
- if (ncol * nrow < length(grobs)) {
+ gp = gp_titles |
| 153 | -1x | +
- stop("specififed ncol and nrow are not enough for arranging the grobs ")
+ ) |
|
| 154 |
- }+ |
||
| 155 | -+ | 9x |
-
+ st_footnotes <- split_text_grob( |
| 156 | -3x | +9x |
- if (ncol == 1) {
+ footnotes, |
| 157 | -2x | +9x |
- return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))+ x = 0, y = 1, |
| 158 | -+ | 9x |
- }+ just = c("left", "top"),
|
| 159 | -+ | 9x |
-
+ width = width_footnotes, |
| 160 | -1x | +9x |
- n_col <- 2 * ncol - 1+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1), |
| 161 | -1x | +9x |
- n_row <- 2 * nrow - 1+ gp = gp_footnotes |
| 162 | -1x | +
- hts <- lapply(+ ) |
|
| 163 | -1x | +
- seq(1, n_row),+ |
|
| 164 | -1x | +9x |
- function(i) {
+ pg_footnote <- grid::textGrob( |
| 165 | -5x | +9x |
- if (i %% 2 != 0) {
+ paste("\n", page),
|
| 166 | -3x | +9x |
- grid::unit(1, "null")+ x = 1, y = 0, |
| 167 | -+ | 9x |
- } else {
+ just = c("right", "bottom"),
|
| 168 | -2x | +9x |
- padding_ht+ vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1), |
| 169 | -+ | 9x |
- }+ gp = gp_footnotes |
| 170 |
- }+ ) |
||
| 171 |
- )+ |
||
| 172 | -1x | +9x |
- hts <- do.call(grid::unit.c, hts)+ grid::gTree( |
| 173 | -+ | 9x |
-
+ grob = grob, |
| 174 | -1x | +9x |
- wts <- lapply(+ titles = titles, |
| 175 | -1x | +9x |
- seq(1, n_col),+ footnotes = footnotes, |
| 176 | -1x | +9x |
- function(i) {
+ page = page, |
| 177 | -5x | +9x |
- if (i %% 2 != 0) {
+ width_titles = width_titles, |
| 178 | -3x | +9x |
- grid::unit(1, "null")+ width_footnotes = width_footnotes, |
| 179 | -+ | 9x |
- } else {
+ border = border, |
| 180 | -2x | +9x |
- padding_wt+ margins = margins, |
| 181 | -+ | 9x |
- }+ padding = padding, |
| 182 | -+ | 9x |
- }+ outer_margins = outer_margins, |
| 183 | -+ | 9x |
- )+ gp_titles = gp_titles, |
| 184 | -1x | +9x |
- wts <- do.call(grid::unit.c, wts)+ gp_footnotes = gp_footnotes, |
| 185 | -+ | 9x |
-
+ children = grid::gList( |
| 186 | -1x | +9x |
- main_vp <- grid::viewport(+ grid::gTree( |
| 187 | -1x | +9x |
- layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)+ children = grid::gList( |
| 188 | -+ | 9x |
- )+ st_titles, |
| 189 | -+ | 9x |
-
+ grid::gTree( |
| 190 | -1x | +9x |
- nested_grobs <- list()+ children = grid::gList( |
| 191 | -1x | +9x |
- k <- 0+ if (border) grid::rectGrob(), |
| 192 | -1x | +9x |
- for (i in seq(nrow) * 2 - 1) {
+ grid::gTree( |
| 193 | -3x | +9x |
- for (j in seq(ncol) * 2 - 1) {
+ children = grid::gList( |
| 194 | 9x |
- k <- k + 1+ grob |
|
| 195 | -9x | +
- if (k <= length(grobs)) {
+ ), |
|
| 196 | 9x |
- nested_grobs <- c(+ vp = grid::plotViewport(margins = padding) |
|
| 197 | -9x | +
- nested_grobs,+ ) |
|
| 198 | -9x | +
- list(grid::gTree(+ ), |
|
| 199 | 9x |
- children = grid::gList(grobs[[k]]),+ vp = grid::vpStack( |
|
| 200 | 9x |
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)+ grid::viewport(layout.pos.row = 2, layout.pos.col = 1), |
|
| 201 | -+ | 9x |
- ))+ grid::plotViewport(margins = margins) |
| 202 |
- )+ ) |
||
| 203 |
- }+ ), |
||
| 204 | -+ | 9x |
- }+ st_footnotes, |
| 205 | -+ | 9x |
- }+ pg_footnote |
| 206 | -1x | +
- grobs_mainvp <- grid::gTree(+ ), |
|
| 207 | -1x | +9x |
- children = do.call(grid::gList, nested_grobs),+ childrenvp = NULL, |
| 208 | -1x | +9x |
- vp = main_vp+ name = "titles_grob_footnotes", |
| 209 | -+ | 9x |
- )+ vp = grid::vpStack( |
| 210 | -+ | 9x |
-
+ grid::plotViewport(margins = outer_margins), |
| 211 | -1x | +9x |
- grid::gTree(+ grid::viewport( |
| 212 | -1x | +9x |
- children = grid::gList(grobs_mainvp),+ layout = grid::grid.layout( |
| 213 | -1x | +9x |
- vp = vp,+ nrow = 4, ncol = 1, |
| 214 | -1x | +9x |
- gp = gp,+ heights = grid::unit.c( |
| 215 | -1x | +9x |
- name = name+ grid::grobHeight(st_titles), |
| 216 | -+ | 9x |
- )+ grid::unit(1, "null"), |
| 217 | -+ | 9x |
- }+ grid::grobHeight(st_footnotes), |
| 218 | -+ | 9x |
-
+ grid::grobHeight(pg_footnote) |
| 219 |
- #' Draw `grob`+ ) |
||
| 220 |
- #'+ ) |
||
| 221 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 222 |
- #'+ ) |
||
| 223 |
- #' Draw grob on device page.+ ) |
||
| 224 |
- #'+ ), |
||
| 225 | -+ | 9x |
- #' @param grob grid object+ name = name, |
| 226 | -+ | 9x |
- #' @param newpage draw on a new page+ gp = gp, |
| 227 | -+ | 9x |
- #' @param vp a [viewport()] object (or `NULL`).+ vp = vp, |
| 228 | -+ | 9x |
- #'+ cl = "decoratedGrob" |
| 229 |
- #' @return A `grob`.+ ) |
||
| 230 |
- #'+ } |
||
| 231 |
- #' @examples+ |
||
| 232 |
- #' library(dplyr)+ #' @importFrom grid validDetails |
||
| 233 |
- #' library(grid)+ #' @noRd |
||
| 234 |
- #'+ validDetails.decoratedGrob <- function(x) {
|
||
| 235 | -+ | ! |
- #' \donttest{
+ checkmate::assert_character(x$titles) |
| 236 | -+ | ! |
- #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))+ checkmate::assert_character(x$footnotes) |
| 237 |
- #' rect %>% draw_grob(vp = grid::viewport(angle = 45))+ |
||
| 238 | -+ | ! |
- #'+ if (!is.null(x$grob)) {
|
| 239 | -+ | ! |
- #' num <- lapply(1:10, textGrob)+ checkmate::assert_true(grid::is.grob(x$grob)) |
| 240 |
- #' num %>%+ } |
||
| 241 | -+ | ! |
- #' arrange_grobs(grobs = .) %>%+ if (length(x$page) == 1) {
|
| 242 | -+ | ! |
- #' draw_grob()+ checkmate::assert_character(x$page) |
| 243 |
- #' showViewport()+ } |
||
| 244 | -+ | ! |
- #' }+ if (!grid::is.unit(x$outer_margins)) {
|
| 245 | -+ | ! |
- #'+ checkmate::assert_vector(x$outer_margins, len = 4) |
| 246 |
- #' @export+ } |
||
| 247 | -+ | ! |
- draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
+ if (!grid::is.unit(x$margins)) {
|
| 248 | -3x | +! |
- if (newpage) {
+ checkmate::assert_vector(x$margins, len = 4) |
| 249 | -3x | +
- grid::grid.newpage()+ } |
|
| 250 | -+ | ! |
- }+ if (!grid::is.unit(x$padding)) {
|
| 251 | -3x | +! |
- if (!is.null(vp)) {
+ checkmate::assert_vector(x$padding, len = 4) |
| 252 | -1x | +
- grid::pushViewport(vp)+ } |
|
| 253 |
- }+ |
||
| 254 | -3x | +! |
- grid::grid.draw(grob)+ x |
| 257 |
- tern_grob <- function(x) {
+ #' @importFrom grid widthDetails |
||
| 258 | ++ |
+ #' @noRd+ |
+ |
| 259 | ++ |
+ widthDetails.decoratedGrob <- function(x) {
+ |
+ |
| 260 | ! |
- class(x) <- unique(c("ternGrob", class(x)))
+ grid::unit(1, "null")+ |
+ |
| 261 | ++ |
+ }+ |
+ |
| 262 | ++ | + + | +|
| 263 | ++ |
+ #' @importFrom grid heightDetails+ |
+ |
| 264 | ++ |
+ #' @noRd+ |
+ |
| 265 | ++ |
+ heightDetails.decoratedGrob <- function(x) {
|
|
| 259 | +266 | ! |
- x+ grid::unit(1, "null") |
| 260 | +267 |
} |
|
| 261 | +268 | ++ | + + | +
| 269 | ++ |
+ # Adapted from Paul Murell R Graphics 2nd Edition+ |
+ |
| 270 | ++ |
+ # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R+ |
+ |
| 271 | ++ |
+ split_string <- function(text, width) {
+ |
+ |
| 272 | +19x | +
+ strings <- strsplit(text, " ")+ |
+ |
| 273 | +19x | +
+ out_string <- NA+ |
+ |
| 274 | +19x | +
+ for (string_i in seq_along(strings)) {
+ |
+ |
| 275 | +19x | +
+ newline_str <- strings[[string_i]]+ |
+ |
| 276 | +6x | +
+ if (length(newline_str) == 0) newline_str <- ""+ |
+ |
| 277 | +19x | +
+ if (is.na(out_string[string_i])) {
+ |
+ |
| 278 | +19x | +
+ out_string[string_i] <- newline_str[[1]][[1]]+ |
+ |
| 279 | +19x | +
+ linewidth <- grid::stringWidth(out_string[string_i])+ |
+ |
| 280 | ++ |
+ }+ |
+ |
| 281 | +19x | +
+ gapwidth <- grid::stringWidth(" ")
+ |
+ |
| 282 | +19x | +
+ availwidth <- as.numeric(width)+ |
+ |
| 283 | +19x | +
+ if (length(newline_str) > 1) {
+ |
+ |
| 284 | +7x | +
+ for (i in seq(2, length(newline_str))) {
+ |
+ |
| 285 | +83x | +
+ width_i <- grid::stringWidth(newline_str[i])+ |
+ |
| 286 | +83x | +
+ if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ |
+ |
| 287 | +78x | +
+ sep <- " "+ |
+ |
| 288 | +78x | +
+ linewidth <- linewidth + gapwidth + width_i+ |
+ |
| 289 | ++ |
+ } else {
+ |
+ |
| 290 | +5x | +
+ sep <- "\n"+ |
+ |
| 291 | +5x | +
+ linewidth <- width_i+ |
+ |
| 292 | ++ |
+ }+ |
+ |
| 293 | +83x | +
+ out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep)+ |
+ |
| 294 | ++ |
+ }+ |
+ |
| 295 | ++ |
+ }+ |
+ |
| 296 | ++ |
+ }+ |
+ |
| 297 | +19x | +
+ paste(out_string, collapse = "\n")+ |
+ |
| 298 | ++ |
+ }+ |
+ |
| 299 | ++ | + + | +|
| 300 |
-
+ #' Split Text According To Available Text Width |
||
| 262 | +301 |
- #' @keywords internal+ #' |
|
| 263 | +302 |
- print.ternGrob <- function(x, ...) {
+ #' Dynamically wrap text. |
|
| 264 | -! | +||
| 303 | +
- grid::grid.newpage()+ #' |
||
| 265 | -! | +||
| 304 | +
- grid::grid.draw(x)+ #' @inheritParams grid::grid.text |
||
| 266 | +305 |
- }+ #' @param text character string |
| 1 | +306 |
- #' Difference Test for Two Proportions+ #' @param width a unit object specifying max width of text |
||
| 2 | +307 |
#' |
||
| 3 | +308 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return A text grob. |
||
| 4 | +309 |
#' |
||
| 5 | +310 |
- #' Various tests were implemented to test the difference between two proportions.+ #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition` |
||
| 6 | +311 |
#' |
||
| 7 | +312 |
- #' @inheritParams argument_convention+ #' @keywords internal |
||
| 8 | +313 |
- #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used+ split_text_grob <- function(text, |
||
| 9 | +314 |
- #' to calculate the p-value.+ x = grid::unit(0.5, "npc"), |
||
| 10 | +315 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("test_proportion_diff")`
+ y = grid::unit(0.5, "npc"), |
||
| 11 | +316 |
- #' to see available statistics for this function.+ width = grid::unit(1, "npc"), |
||
| 12 | +317 |
- #'+ just = "centre", |
||
| 13 | +318 |
- #' @seealso [h_prop_diff_test]+ hjust = NULL, |
||
| 14 | +319 |
- #'+ vjust = NULL, |
||
| 15 | +320 |
- #' @name prop_diff_test+ default.units = "npc", # nolint |
||
| 16 | +321 |
- #' @order 1+ name = NULL, |
||
| 17 | +322 |
- NULL+ gp = grid::gpar(), |
||
| 18 | +323 |
-
+ vp = NULL) {
|
||
| 19 | -+ | |||
| 324 | +18x |
- #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions.+ if (!grid::is.unit(x)) x <- grid::unit(x, default.units) |
||
| 20 | -+ | |||
| 325 | +18x |
- #'+ if (!grid::is.unit(y)) y <- grid::unit(y, default.units) |
||
| 21 | -+ | |||
| 326 | +! |
- #' @return+ if (!grid::is.unit(width)) width <- grid::unit(width, default.units) |
||
| 22 | -+ | |||
| 327 | +! |
- #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`+ if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
|
||
| 23 | -+ | |||
| 328 | +! |
- #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.+ if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
|
||
| 24 | -+ | |||
| 329 | +18x |
- #'+ if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
|
||
| 25 | +330 |
- #' @keywords internal+ |
||
| 26 | -+ | |||
| 331 | +18x |
- s_test_proportion_diff <- function(df,+ if (length(gp) > 0) { # account for effect of gp on text width
|
||
| 27 | -+ | |||
| 332 | +9x |
- .var,+ width <- width * grid::convertWidth(grid::grobWidth(grid::textGrob(text)), "npc", valueOnly = TRUE) / |
||
| 28 | -+ | |||
| 333 | +9x |
- .ref_group,+ grid::convertWidth(grid::grobWidth(grid::textGrob(text, gp = gp)), "npc", valueOnly = TRUE) |
||
| 29 | +334 |
- .in_ref_col,+ } |
||
| 30 | +335 |
- variables = list(strata = NULL),+ |
||
| 31 | +336 |
- method = c("chisq", "schouten", "fisher", "cmh")) {
+ ## if it is a fixed unit then we do not need to recalculate when viewport resized |
||
| 32 | -35x | +337 | +18x |
- method <- match.arg(method)+ if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) && |
| 33 | -35x | +338 | +18x |
- y <- list(pval = "")+ attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
+ |
+
| 339 | +! | +
+ attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n") |
||
| 34 | +340 | ++ |
+ }+ |
+ |
| 341 | ||||
| 35 | -35x | +342 | +18x |
- if (!.in_ref_col) {
+ grid::grid.text( |
| 36 | -35x | +343 | +18x |
- assert_df_with_variables(df, list(rsp = .var))+ label = split_string(text, width), |
| 37 | -35x | +344 | +18x |
- assert_df_with_variables(.ref_group, list(rsp = .var))+ x = x, y = y, |
| 38 | -35x | +345 | +18x |
- rsp <- factor(+ just = just, |
| 39 | -35x | +346 | +18x |
- c(.ref_group[[.var]], df[[.var]]),+ hjust = hjust, |
| 40 | -35x | +347 | +18x |
- levels = c("TRUE", "FALSE")
+ vjust = vjust, |
| 41 | -+ | |||
| 348 | +18x |
- )+ rot = 0, |
||
| 42 | -35x | +349 | +18x |
- grp <- factor(+ check.overlap = FALSE, |
| 43 | -35x | +350 | +18x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ name = name, |
| 44 | -35x | +351 | +18x |
- levels = c("ref", "Not-ref")
+ gp = gp,+ |
+
| 352 | +18x | +
+ vp = vp,+ |
+ ||
| 353 | +18x | +
+ draw = FALSE |
||
| 45 | +354 |
- )+ ) |
||
| 46 | +355 | ++ |
+ }+ |
+ |
| 356 | ||||
| 47 | -35x | +|||
| 357 | +
- if (!is.null(variables$strata) || method == "cmh") {
+ #' @importFrom grid validDetails |
|||
| 48 | -12x | +|||
| 358 | +
- strata <- variables$strata+ #' @noRd |
|||
| 49 | -12x | +|||
| 359 | +
- checkmate::assert_false(is.null(strata))+ validDetails.dynamicSplitText <- function(x) {
|
|||
| 50 | -12x | +|||
| 360 | +! |
- strata_vars <- stats::setNames(as.list(strata), strata)+ checkmate::assert_character(x$text) |
||
| 51 | -12x | +|||
| 361 | +! |
- assert_df_with_variables(df, strata_vars)+ checkmate::assert_true(grid::is.unit(x$width)) |
||
| 52 | -12x | +|||
| 362 | +! |
- assert_df_with_variables(.ref_group, strata_vars)+ checkmate::assert_vector(x$width, len = 1) |
||
| 53 | -12x | +|||
| 363 | +! |
- strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))+ x |
||
| 54 | +364 |
- }+ } |
||
| 55 | +365 | |||
| 56 | -35x | +|||
| 366 | +
- tbl <- switch(method,+ #' @importFrom grid heightDetails |
|||
| 57 | -35x | +|||
| 367 | +
- cmh = table(grp, rsp, strata),+ #' @noRd |
|||
| 58 | -35x | +|||
| 368 | +
- table(grp, rsp)+ heightDetails.dynamicSplitText <- function(x) {
+ |
+ |||
| 369 | +! | +
+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ |
+ ||
| 370 | +! | +
+ attr(x$text, "fixed_text") |
||
| 59 | +371 |
- )+ } else {
+ |
+ ||
| 372 | +! | +
+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 60 | +373 |
-
+ } |
||
| 61 | -35x | +|||
| 374 | +! |
- y$pval <- switch(method,+ grid::stringHeight(txt) |
||
| 62 | -35x | +|||
| 375 | +
- chisq = prop_chisq(tbl),+ } |
|||
| 63 | -35x | +|||
| 376 | +
- cmh = prop_cmh(tbl),+ |
|||
| 64 | -35x | +|||
| 377 | +
- fisher = prop_fisher(tbl),+ #' @importFrom grid widthDetails |
|||
| 65 | -35x | +|||
| 378 | +
- schouten = prop_schouten(tbl)+ #' @noRd |
|||
| 66 | +379 |
- )+ widthDetails.dynamicSplitText <- function(x) {
+ |
+ ||
| 380 | +! | +
+ x$width |
||
| 67 | +381 |
- }+ } |
||
| 68 | +382 | |||
| 69 | -35x | +|||
| 383 | +
- y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))+ #' @importFrom grid drawDetails |
|||
| 70 | -35x | +|||
| 384 | +
- y+ #' @noRd |
|||
| 71 | +385 |
- }+ drawDetails.dynamicSplitText <- function(x, recording) {
+ |
+ ||
| 386 | +! | +
+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ |
+ ||
| 387 | +! | +
+ attr(x$text, "fixed_text") |
||
| 72 | +388 |
-
+ } else {
+ |
+ ||
| 389 | +! | +
+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 73 | +390 |
- #' Description of the Difference Test Between Two Proportions+ } |
||
| 74 | +391 |
- #'+ + |
+ ||
| 392 | +! | +
+ x$width <- NULL+ |
+ ||
| 393 | +! | +
+ x$label <- txt+ |
+ ||
| 394 | +! | +
+ x$text <- NULL+ |
+ ||
| 395 | +! | +
+ class(x) <- c("text", class(x)[-1])
|
||
| 75 | +396 |
- #' @description `r lifecycle::badge("stable")`
+
+ |
+ ||
| 397 | +! | +
+ grid::grid.draw(x) |
||
| 76 | +398 |
- #'+ } |
||
| 77 | +399 |
- #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`.+ |
||
| 78 | +400 | ++ |
+ #' Update Page Number+ |
+ |
| 401 |
#' |
|||
| 79 | +402 |
- #' @inheritParams s_test_proportion_diff+ #' Automatically updates page number. |
||
| 80 | +403 |
#' |
||
| 81 | +404 |
- #' @return `string` describing the test from which the p-value is derived.+ #' @param npages number of pages in total |
||
| 82 | +405 | ++ |
+ #' @param ... passed on to [decorate_grob()]+ |
+ |
| 406 |
#' |
|||
| 83 | +407 |
- #' @export+ #' @return Closure that increments the page number. |
||
| 84 | +408 |
- d_test_proportion_diff <- function(method) {
+ #' |
||
| 85 | -49x | +|||
| 409 | +
- checkmate::assert_string(method)+ #' @keywords internal |
|||
| 86 | -49x | +|||
| 410 | +
- meth_part <- switch(method,+ decorate_grob_factory <- function(npages, ...) {
|
|||
| 87 | -49x | +411 | +2x |
- "schouten" = "Chi-Squared Test with Schouten Correction",+ current_page <- 0 |
| 88 | -49x | +412 | +2x |
- "chisq" = "Chi-Squared Test",+ function(grob) {
|
| 89 | -49x | +413 | +7x |
- "cmh" = "Cochran-Mantel-Haenszel Test",+ current_page <<- current_page + 1 |
| 90 | -49x | +414 | +7x |
- "fisher" = "Fisher's Exact Test",+ if (current_page > npages) {
|
| 91 | -49x | +415 | +1x |
- stop(paste(method, "does not have a description"))+ stop(paste("current page is", current_page, "but max.", npages, "specified."))
|
| 92 | +416 |
- )+ } |
||
| 93 | -49x | +417 | +6x |
- paste0("p-value (", meth_part, ")")
+ decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
|
| 94 | +418 |
- }+ } |
||
| 95 | +419 |
-
+ } |
||
| 96 | +420 |
- #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`.+ |
||
| 97 | +421 |
- #'+ #' Decorate Set of `grobs` and Add Page Numbering |
||
| 98 | +422 |
- #' @return+ #' |
||
| 99 | +423 |
- #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 100 | +424 |
#' |
||
| 101 | +425 |
- #' @keywords internal+ #' Note that this uses the [decorate_grob_factory()] function. |
||
| 102 | +426 |
- a_test_proportion_diff <- make_afun(+ #' |
||
| 103 | +427 |
- s_test_proportion_diff,+ #' @param grobs a list of grid grobs |
||
| 104 | +428 |
- .formats = c(pval = "x.xxxx | (<0.0001)"),+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 105 | +429 |
- .indent_mods = c(pval = 1L)+ #' |
||
| 106 | +430 |
- )+ #' @return A decorated grob. |
||
| 107 | +431 |
-
+ #' |
||
| 108 | +432 |
- #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments+ #' @examples |
||
| 109 | +433 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' library(ggplot2) |
||
| 110 | +434 |
- #'+ #' library(grid) |
||
| 111 | +435 |
- #' @return+ #' g <- with(data = iris, {
|
||
| 112 | +436 |
- #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ #' list( |
||
| 113 | +437 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' ggplot2::ggplotGrob( |
||
| 114 | +438 |
- #' the statistics from `s_test_proportion_diff()` to the table layout.+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 115 | +439 |
- #'+ #' ggplot2::geom_point() |
||
| 116 | +440 |
- #' @examples+ #' ), |
||
| 117 | +441 |
- #' dta <- data.frame(+ #' ggplot2::ggplotGrob( |
||
| 118 | +442 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) + |
||
| 119 | +443 |
- #' grp = factor(rep(c("A", "B"), each = 50)),
+ #' ggplot2::geom_point() |
||
| 120 | +444 |
- #' strat = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
+ #' ), |
||
| 121 | +445 |
- #' )+ #' ggplot2::ggplotGrob( |
||
| 122 | +446 |
- #'+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) + |
||
| 123 | +447 |
- #' # With `rtables` pipelines.+ #' ggplot2::geom_point() |
||
| 124 | +448 |
- #' l <- basic_table() %>%+ #' ), |
||
| 125 | +449 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ #' ggplot2::ggplotGrob( |
||
| 126 | +450 |
- #' test_proportion_diff(+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) + |
||
| 127 | +451 |
- #' vars = "rsp",+ #' ggplot2::geom_point() |
||
| 128 | +452 |
- #' method = "cmh", variables = list(strata = "strat")+ #' ), |
||
| 129 | +453 |
- #' )+ #' ggplot2::ggplotGrob( |
||
| 130 | +454 |
- #'+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) + |
||
| 131 | +455 |
- #' build_table(l, df = dta)+ #' ggplot2::geom_point() |
||
| 132 | +456 |
- #'+ #' ), |
||
| 133 | +457 |
- #' @export+ #' ggplot2::ggplotGrob( |
||
| 134 | +458 |
- #' @order 2+ #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) + |
||
| 135 | +459 |
- test_proportion_diff <- function(lyt,+ #' ggplot2::geom_point() |
||
| 136 | +460 |
- vars,+ #' ) |
||
| 137 | +461 |
- variables = list(strata = NULL),+ #' ) |
||
| 138 | +462 |
- method = c("chisq", "schouten", "fisher", "cmh"),
+ #' }) |
||
| 139 | +463 |
- na_str = default_na_str(),+ #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "") |
||
| 140 | +464 |
- nested = TRUE,+ #' |
||
| 141 | +465 |
- ...,+ #' draw_grob(lg[[1]]) |
||
| 142 | +466 |
- var_labels = vars,+ #' draw_grob(lg[[2]]) |
||
| 143 | +467 |
- show_labels = "hidden",+ #' draw_grob(lg[[6]]) |
||
| 144 | +468 |
- table_names = vars,+ #' |
||
| 145 | +469 |
- .stats = NULL,+ #' @export |
||
| 146 | +470 |
- .formats = NULL,+ decorate_grob_set <- function(grobs, ...) {
|
||
| 147 | -+ | |||
| 471 | +1x |
- .labels = NULL,+ n <- length(grobs) |
||
| 148 | -+ | |||
| 472 | +1x |
- .indent_mods = NULL) {
+ lgf <- decorate_grob_factory(npages = n, ...) |
||
| 149 | -6x | +473 | +1x |
- extra_args <- list(variables = variables, method = method, ...)+ lapply(grobs, lgf) |
| 150 | +474 |
-
+ } |
||
| 151 | -6x | +
| 1 | +
- afun <- make_afun(+ #' Patient Counts for Laboratory Events (Worsen From Baseline) by Highest Grade Post-Baseline |
|||
| 152 | -6x | +|||
| 2 | +
- a_test_proportion_diff,+ #' |
|||
| 153 | -6x | +|||
| 3 | +
- .stats = .stats,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 154 | -6x | +|||
| 4 | +
- .formats = .formats,+ #' |
|||
| 155 | -6x | +|||
| 5 | +
- .labels = .labels,+ #' Patient count and fraction for laboratory events (worsen from baseline) shift table. |
|||
| 156 | -6x | +|||
| 6 | +
- .indent_mods = .indent_mods+ #' |
|||
| 157 | +7 |
- )+ #' @inheritParams argument_convention |
||
| 158 | -6x | +|||
| 8 | +
- analyze(+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables including: |
|||
| 159 | -6x | +|||
| 9 | +
- lyt,+ #' * `id` (`string`)\cr subject variable name. |
|||
| 160 | -6x | +|||
| 10 | +
- vars,+ #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable. |
|||
| 161 | -6x | +|||
| 11 | +
- afun = afun,+ #' * `direction_var` (`string`)\cr see `direction_var` for more details. |
|||
| 162 | -6x | +|||
| 12 | +
- var_labels = var_labels,+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade_worsen")`
|
|||
| 163 | -6x | +|||
| 13 | +
- na_str = na_str,+ #' to see all available statistics. |
|||
| 164 | -6x | +|||
| 14 | +
- nested = nested,- |
- |||
| 165 | -6x | +|||
| 15 | +
- extra_args = extra_args,+ #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] |
|||
| 166 | -6x | +|||
| 16 | +
- show_labels = show_labels,+ #' |
|||
| 167 | -6x | +|||
| 17 | +
- table_names = table_names+ #' @name abnormal_by_worst_grade_worsen |
|||
| 168 | +18 |
- )+ #' @order 1 |
||
| 169 | +19 |
- }+ NULL |
||
| 170 | +20 | |||
| 171 | +21 |
- #' Helper Functions to Test Proportion Differences+ #' Helper Function to Prepare `ADLB` with Worst Labs |
||
| 172 | +22 |
#' |
||
| 173 | +23 |
- #' Helper functions to implement various tests on the difference between two proportions.+ #' @description `r lifecycle::badge("stable")`
|
||
| 174 | +24 |
#' |
||
| 175 | +25 |
- #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns.+ #' Helper function to prepare a `df` for generate the patient count shift table |
||
| 176 | +26 |
#' |
||
| 177 | +27 |
- #' @return A p-value.+ #' @param adlb (`data.frame`)\cr `ADLB` dataframe |
||
| 178 | +28 |
- #'+ #' @param worst_flag_low (named `vector`)\cr Worst low post-baseline lab grade flag variable |
||
| 179 | +29 |
- #' @seealso [prop_diff_test()] for implementation of these helper functions.+ #' @param worst_flag_high (named `vector`)\cr Worst high post-baseline lab grade flag variable |
||
| 180 | +30 |
- #'+ #' @param direction_var (`string`)\cr Direction variable specifying the direction of the shift table of interest. |
||
| 181 | +31 |
- #' @name h_prop_diff_test+ #' Only lab records flagged by `L`, `H` or `B` are included in the shift table. |
||
| 182 | +32 |
- NULL+ #' * `L`: low direction only |
||
| 183 | +33 |
-
+ #' * `H`: high direction only |
||
| 184 | +34 |
- #' @describeIn h_prop_diff_test performs Chi-Squared test. Internally calls [stats::prop.test()].+ #' * `B`: both low and high directions |
||
| 185 | +35 |
#' |
||
| 186 | +36 |
- #' @keywords internal+ #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the |
||
| 187 | +37 |
- prop_chisq <- function(tbl) {
+ #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the |
||
| 188 | -30x | +|||
| 38 | +
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ #' direction specified according to `direction_var`. For instance, for a lab that is |
|||
| 189 | -30x | +|||
| 39 | +
- tbl <- tbl[, c("TRUE", "FALSE")]
+ #' needed for the low direction only, only records flagged by `worst_flag_low` are |
|||
| 190 | -30x | +|||
| 40 | +
- if (any(colSums(tbl) == 0)) {
+ #' selected. For a lab that is needed for both low and high directions, the worst |
|||
| 191 | -2x | +|||
| 41 | +
- return(1)+ #' low records are selected for the low direction, and the worst high record are selected |
|||
| 192 | +42 |
- }+ #' for the high direction. |
||
| 193 | -28x | +|||
| 43 | +
- stats::prop.test(tbl, correct = FALSE)$p.value+ #' |
|||
| 194 | +44 |
- }+ #' @seealso [abnormal_by_worst_grade_worsen] |
||
| 195 | +45 |
-
+ #' |
||
| 196 | +46 |
- #' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test. Internally calls+ #' @examples |
||
| 197 | +47 |
- #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded.+ #' library(dplyr) |
||
| 198 | +48 |
#' |
||
| 199 | +49 |
- #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response+ #' # The direction variable, GRADDR, is based on metadata |
||
| 200 | +50 |
- #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.+ #' adlb <- tern_ex_adlb %>% |
||
| 201 | +51 |
- #'+ #' mutate( |
||
| 202 | +52 |
- #' @keywords internal+ #' GRADDR = case_when( |
||
| 203 | +53 |
- prop_cmh <- function(ary) {
+ #' PARAMCD == "ALT" ~ "B", |
||
| 204 | -16x | +|||
| 54 | +
- checkmate::assert_array(ary)+ #' PARAMCD == "CRP" ~ "L", |
|||
| 205 | -16x | +|||
| 55 | +
- checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)+ #' PARAMCD == "IGA" ~ "H" |
|||
| 206 | -16x | +|||
| 56 | +
- checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)+ #' ) |
|||
| 207 | -16x | +|||
| 57 | +
- strata_sizes <- apply(ary, MARGIN = 3, sum)+ #' ) %>% |
|||
| 208 | -16x | +|||
| 58 | +
- if (any(strata_sizes < 5)) {
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|||
| 209 | -1x | +|||
| 59 | +
- warning("<5 data points in some strata. CMH test may be incorrect.")
+ #' |
|||
| 210 | -1x | +|||
| 60 | +
- ary <- ary[, , strata_sizes > 1]+ #' df <- h_adlb_worsen( |
|||
| 211 | +61 |
- }+ #' adlb, |
||
| 212 | +62 |
-
+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 213 | -16x | +|||
| 63 | +
- stats::mantelhaen.test(ary, correct = FALSE)$p.value+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
|||
| 214 | +64 |
- }+ #' direction_var = "GRADDR" |
||
| 215 | +65 |
-
+ #' ) |
||
| 216 | +66 |
- #' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten correction.+ #' |
||
| 217 | +67 |
- #'+ #' @export |
||
| 218 | +68 |
- #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
+ h_adlb_worsen <- function(adlb, |
||
| 219 | +69 |
- #'+ worst_flag_low = NULL, |
||
| 220 | +70 |
- #' @keywords internal+ worst_flag_high = NULL, |
||
| 221 | +71 |
- prop_schouten <- function(tbl) {
+ direction_var) {
|
||
| 222 | -100x | +72 | +5x |
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ checkmate::assert_string(direction_var) |
| 223 | -100x | +73 | +5x |
- tbl <- tbl[, c("TRUE", "FALSE")]
+ checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
|
| 224 | -100x | +74 | +5x |
- if (any(colSums(tbl) == 0)) {
+ assert_df_with_variables(adlb, list("Col" = direction_var))
+ |
+
| 75 | ++ | + | ||
| 225 | -1x | +76 | +5x |
- return(1)+ if (any(unique(adlb[[direction_var]]) == "H")) {
+ |
+
| 77 | +4x | +
+ assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
|
||
| 226 | +78 |
} |
||
| 227 | +79 | |||
| 228 | -99x | +80 | +5x |
- n <- sum(tbl)+ if (any(unique(adlb[[direction_var]]) == "L")) {
|
| 229 | -99x | +81 | +4x |
- n1 <- sum(tbl[1, ])+ assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
|
| 230 | -99x | +|||
| 82 | +
- n2 <- sum(tbl[2, ])+ } |
|||
| 231 | +83 | |||
| 232 | -99x | -
- ad <- diag(tbl)- |
- ||
| 233 | -99x | +84 | +5x |
- bc <- diag(apply(tbl, 2, rev))+ if (any(unique(adlb[[direction_var]]) == "B")) {
|
| 234 | -99x | +85 | +3x |
- ac <- tbl[, 1]+ assert_df_with_variables( |
| 235 | -99x | -
- bd <- tbl[, 2]- |
- ||
| 236 | -+ | 86 | +3x |
-
+ adlb, |
| 237 | -99x | +87 | +3x |
- t_schouten <- (n - 1) *+ list( |
| 238 | -99x | +88 | +3x |
- (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /+ "Low" = names(worst_flag_low), |
| 239 | -99x | +89 | +3x |
- (n1 * n2 * sum(ac) * sum(bd))+ "High" = names(worst_flag_high) |
| 240 | +90 |
-
+ ) |
||
| 241 | -99x | +|||
| 91 | +
- 1 - stats::pchisq(t_schouten, df = 1)+ ) |
|||
| 242 | +92 |
- }+ } |
||
| 243 | +93 | |||
| 244 | +94 |
- #' @describeIn h_prop_diff_test performs the Fisher's exact test. Internally calls [stats::fisher.test()].+ # extract patients with worst post-baseline lab, either low or high or both |
||
| 245 | -+ | |||
| 95 | +5x |
- #'+ worst_flag <- c(worst_flag_low, worst_flag_high) |
||
| 246 | -+ | |||
| 96 | +5x |
- #' @keywords internal+ col_names <- names(worst_flag) |
||
| 247 | -+ | |||
| 97 | +5x |
- prop_fisher <- function(tbl) {
+ filter_values <- worst_flag |
||
| 248 | -2x | +98 | +5x |
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ temp <- Map( |
| 249 | -2x | +99 | +5x |
- tbl <- tbl[, c("TRUE", "FALSE")]
+ function(x, y) which(adlb[[x]] == y), |
| 250 | -2x | +100 | +5x |
- stats::fisher.test(tbl)$p.value+ col_names, |
| 251 | -+ | |||
| 101 | +5x |
- }+ filter_values |
| 1 | +102 |
- #' Missing Data+ ) |
||
| 2 | -+ | |||
| 103 | +5x |
- #'+ position_satisfy_filters <- Reduce(union, temp) |
||
| 3 | +104 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | +105 |
- #'+ # select variables of interest |
||
| 5 | -+ | |||
| 106 | +5x |
- #' Substitute missing data with a string or factor level.+ adlb_f <- adlb[position_satisfy_filters, ] |
||
| 6 | +107 |
- #'+ |
||
| 7 | +108 |
- #' @param x (`factor` or `character` vector)\cr values for which any missing values should be substituted.+ # generate subsets for different directionality |
||
| 8 | -+ | |||
| 109 | +5x |
- #' @param label (`character`)\cr string that missing data should be replaced with.+ adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ] |
||
| 9 | -+ | |||
| 110 | +5x |
- #'+ adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ] |
||
| 10 | -+ | |||
| 111 | +5x |
- #' @return `x` with any `NA` values substituted by `label`.+ adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ] |
||
| 11 | +112 |
- #'+ |
||
| 12 | +113 |
- #' @examples+ # for labs requiring both high and low, data is duplicated and will be stacked on top of each other |
||
| 13 | -+ | |||
| 114 | +5x |
- #' explicit_na(c(NA, "a", "b"))+ adlb_f_b_h <- adlb_f_b |
||
| 14 | -+ | |||
| 115 | +5x |
- #' is.na(explicit_na(c(NA, "a", "b")))+ adlb_f_b_l <- adlb_f_b |
||
| 15 | +116 |
- #'+ |
||
| 16 | +117 |
- #' explicit_na(factor(c(NA, "a", "b")))+ # extract data with worst lab |
||
| 17 | -+ | |||
| 118 | +5x |
- #' is.na(explicit_na(factor(c(NA, "a", "b"))))+ if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
|
||
| 18 | +119 |
- #'+ # change H to High, L to Low |
||
| 19 | -+ | |||
| 120 | +3x |
- #' explicit_na(sas_na(c("a", "")))
+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 20 | -+ | |||
| 121 | +3x |
- #'+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
||
| 21 | +122 |
- #' @export+ |
||
| 22 | +123 |
- explicit_na <- function(x, label = "<Missing>") {
+ # change, B to High and Low |
||
| 23 | -220x | +124 | +3x |
- checkmate::assert_string(label)+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ |
+
| 125 | +3x | +
+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
||
| 24 | +126 | |||
| 25 | -220x | +127 | +3x |
- if (is.factor(x)) {
+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
| 26 | -128x | +128 | +3x |
- x <- forcats::fct_na_value_to_level(x, label)+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
| 27 | -128x | +129 | +3x |
- forcats::fct_drop(x, only = label)+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
| 28 | -92x | +130 | +3x |
- } else if (is.character(x)) {
+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ |
+
| 131 | ++ | + | ||
| 29 | -92x | +132 | +3x |
- x[is.na(x)] <- label+ out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l) |
| 30 | -92x | +133 | +2x |
- x+ } else if (!is.null(worst_flag_high)) {
|
| 31 | -+ | |||
| 134 | +1x |
- } else {
+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 32 | -! | +|||
| 135 | +1x |
- stop("only factors and character vectors allowed")
+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
||
| 33 | +136 |
- }+ |
||
| 34 | -+ | |||
| 137 | +1x |
- }+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ |
+ ||
| 138 | +1x | +
+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 35 | +139 | |||
| 36 | -+ | |||
| 140 | +1x |
- #' Convert Strings to `NA`+ out <- rbind(adlb_out_h, adlb_out_b_h) |
||
| 37 | -+ | |||
| 141 | +1x |
- #'+ } else if (!is.null(worst_flag_low)) {
+ |
+ ||
| 142 | +1x | +
+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ |
+ ||
| 143 | +1x | +
+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
||
| 38 | +144 |
- #' @description `r lifecycle::badge("stable")`
+
+ |
+ ||
| 145 | +1x | +
+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ |
+ ||
| 146 | +1x | +
+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 39 | +147 |
- #'+ + |
+ ||
| 148 | +1x | +
+ out <- rbind(adlb_out_l, adlb_out_b_l) |
||
| 40 | +149 |
- #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to+ } |
||
| 41 | +150 |
- #' convert these values to `NA`s.+ |
||
| 42 | +151 |
- #'+ # label+ |
+ ||
| 152 | +5x | +
+ formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE) |
||
| 43 | +153 |
- #' @inheritParams explicit_na+ # NA+ |
+ ||
| 154 | +5x | +
+ out |
||
| 44 | +155 |
- #' @param empty (`logical`)\cr if `TRUE` empty strings get replaced by `NA`.+ } |
||
| 45 | +156 |
- #' @param whitespaces (`logical`)\cr if `TRUE` then strings made from whitespaces only get replaced with `NA`.+ |
||
| 46 | +157 |
- #'+ #' Helper Function to Analyze Patients for [s_count_abnormal_lab_worsen_by_baseline()] |
||
| 47 | +158 |
- #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of+ #' |
||
| 48 | +159 |
- #' `empty` and `whitespaces`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 49 | +160 |
#' |
||
| 50 | +161 |
- #' @examples+ #' Helper function to count the number of patients and the fraction of patients according to |
||
| 51 | +162 |
- #' sas_na(c("1", "", " ", " ", "b"))
+ #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`, |
||
| 52 | +163 |
- #' sas_na(factor(c("", " ", "b")))
+ #' and the direction of interest specified in `direction_var`. |
||
| 53 | +164 |
#' |
||
| 54 | +165 |
- #' is.na(sas_na(c("1", "", " ", " ", "b")))
+ #' @inheritParams argument_convention |
||
| 55 | +166 |
- #'+ #' @inheritParams h_adlb_worsen |
||
| 56 | +167 |
- #' @export+ #' @param baseline_var (`string`)\cr baseline lab grade variable |
||
| 57 | +168 |
- sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
+ #' |
||
| 58 | -217x | +|||
| 169 | +
- checkmate::assert_flag(empty)+ #' @return `h_worsen_counter()` returns the counts and fraction of patients |
|||
| 59 | -217x | +|||
| 170 | +
- checkmate::assert_flag(whitespaces)+ #' whose worst post-baseline lab grades are worse than their baseline grades, for |
|||
| 60 | +171 |
-
+ #' post-baseline worst grades "1", "2", "3", "4" and "Any". |
||
| 61 | -217x | +|||
| 172 | +
- if (is.factor(x)) {
+ #' |
|||
| 62 | -121x | +|||
| 173 | +
- empty_levels <- levels(x) == ""+ #' @seealso [abnormal_by_worst_grade_worsen] |
|||
| 63 | -11x | +|||
| 174 | +
- if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA+ #' |
|||
| 64 | +175 |
-
+ #' @examples |
||
| 65 | -121x | +|||
| 176 | +
- ws_levels <- grepl("^\\s+$", levels(x))
+ #' library(dplyr) |
|||
| 66 | -! | +|||
| 177 | +
- if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA+ #' |
|||
| 67 | +178 |
-
+ #' # The direction variable, GRADDR, is based on metadata |
||
| 68 | -121x | +|||
| 179 | +
- x+ #' adlb <- tern_ex_adlb %>% |
|||
| 69 | -96x | +|||
| 180 | +
- } else if (is.character(x)) {
+ #' mutate( |
|||
| 70 | -96x | +|||
| 181 | +
- if (empty) x[x == ""] <- NA_character_+ #' GRADDR = case_when( |
|||
| 71 | +182 |
-
+ #' PARAMCD == "ALT" ~ "B", |
||
| 72 | -96x | +|||
| 183 | +
- if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
+ #' PARAMCD == "CRP" ~ "L", |
|||
| 73 | +184 |
-
+ #' PARAMCD == "IGA" ~ "H" |
||
| 74 | -96x | +|||
| 185 | +
- x+ #' ) |
|||
| 75 | +186 |
- } else {
+ #' ) %>% |
||
| 76 | -! | +|||
| 187 | +
- stop("only factors and character vectors allowed")
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|||
| 77 | +188 |
- }+ #' |
||
| 78 | +189 |
- }+ #' df <- h_adlb_worsen( |
| 1 | +190 |
- #' Pairwise `CoxPH` model+ #' adlb, |
||
| 2 | +191 |
- #'+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 3 | +192 |
- #' @description `r lifecycle::badge("stable")`
+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 4 | +193 |
- #'+ #' direction_var = "GRADDR" |
||
| 5 | +194 |
- #' Summarize p-value, HR and CIs from stratified or unstratified `CoxPH` model.+ #' ) |
||
| 6 | +195 |
#' |
||
| 7 | +196 |
- #' @inheritParams argument_convention+ #' # `h_worsen_counter` |
||
| 8 | +197 |
- #' @inheritParams s_surv_time+ #' h_worsen_counter( |
||
| 9 | +198 |
- #' @param strat (`character` or `NULL`)\cr variable names indicating stratification factors.+ #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"), |
||
| 10 | +199 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' id = "USUBJID", |
||
| 11 | +200 |
- #' [control_coxph()]. Some possible parameter options are:+ #' .var = "ATOXGR", |
||
| 12 | +201 |
- #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. Default method is `"log-rank"` which+ #' baseline_var = "BTOXGR", |
||
| 13 | +202 |
- #' comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` (from [survival::coxph()]).+ #' direction_var = "GRADDR" |
||
| 14 | +203 |
- #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`,+ #' ) |
||
| 15 | +204 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ #' |
||
| 16 | +205 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ #' @export |
||
| 17 | +206 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("coxph_pairwise")`
+ h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
|
||
| 18 | -+ | |||
| 207 | +17x |
- #' to see available statistics for this function.+ checkmate::assert_string(id) |
||
| 19 | -+ | |||
| 208 | +17x |
- #'+ checkmate::assert_string(.var) |
||
| 20 | -+ | |||
| 209 | +17x |
- #' @name survival_coxph_pairwise+ checkmate::assert_string(baseline_var) |
||
| 21 | -+ | |||
| 210 | +17x |
- #' @order 1+ checkmate::assert_scalar(unique(df[[direction_var]])) |
||
| 22 | -+ | |||
| 211 | +17x |
- NULL+ checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
|
||
| 23 | -+ | |||
| 212 | +17x |
-
+ assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var))) |
||
| 24 | +213 |
- #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR and p-value of a `coxph` model.+ |
||
| 25 | +214 |
- #'+ # remove post-baseline missing |
||
| 26 | -+ | |||
| 215 | +17x |
- #' @return+ df <- df[df[[.var]] != "<Missing>", ] |
||
| 27 | +216 |
- #' * `s_coxph_pairwise()` returns the statistics:+ |
||
| 28 | +217 |
- #' * `pvalue`: p-value to test HR = 1.+ # obtain directionality |
||
| 29 | -+ | |||
| 218 | +17x |
- #' * `hr`: Hazard ratio.+ direction <- unique(df[[direction_var]]) |
||
| 30 | +219 |
- #' * `hr_ci`: Confidence interval for hazard ratio.+ |
||
| 31 | -+ | |||
| 220 | +17x |
- #' * `n_tot`: Total number of observations.+ if (direction == "Low") {
|
||
| 32 | -+ | |||
| 221 | +10x |
- #' * `n_tot_events`: Total number of events.+ grade <- -1:-4 |
||
| 33 | -+ | |||
| 222 | +10x |
- #'+ worst_grade <- -4 |
||
| 34 | -+ | |||
| 223 | +7x |
- #' @keywords internal+ } else if (direction == "High") {
|
||
| 35 | -+ | |||
| 224 | +7x |
- s_coxph_pairwise <- function(df,+ grade <- 1:4 |
||
| 36 | -+ | |||
| 225 | +7x |
- .ref_group,+ worst_grade <- 4 |
||
| 37 | +226 |
- .in_ref_col,+ } |
||
| 38 | +227 |
- .var,+ |
||
| 39 | -+ | |||
| 228 | +17x |
- is_event,+ if (nrow(df) > 0) {
|
||
| 40 | -+ | |||
| 229 | +17x |
- strat = NULL,+ by_grade <- lapply(grade, function(i) {
|
||
| 41 | +230 |
- control = control_coxph()) {
+ # filter baseline values that is less than i or <Missing> |
||
| 42 | -71x | +231 | +68x |
- checkmate::assert_string(.var)+ df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ] |
| 43 | -71x | +|||
| 232 | +
- checkmate::assert_numeric(df[[.var]])+ # num: number of patients with post-baseline worst lab equal to i |
|||
| 44 | -71x | +233 | +68x |
- checkmate::assert_logical(df[[is_event]])+ num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE])) |
| 45 | -71x | +|||
| 234 | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction |
|||
| 46 | -71x | +235 | +68x |
- pval_method <- control$pval_method+ denom <- length(unique(df_temp[[id]])) |
| 47 | -71x | +236 | +68x |
- ties <- control$ties+ rm(df_temp) |
| 48 | -71x | +237 | +68x |
- conf_level <- control$conf_level+ c(num = num, denom = denom) |
| 49 | +238 |
-
+ }) |
||
| 50 | -71x | +|||
| 239 | +
- if (.in_ref_col) {
+ } else {
|
|||
| 51 | +240 | ! |
- return(+ by_grade <- lapply(1, function(i) {
|
|
| 52 | +241 | ! |
- list(+ c(num = 0, denom = 0) |
|
| 53 | -! | +|||
| 242 | +
- pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
+ }) |
|||
| 54 | -! | +|||
| 243 | +
- hr = formatters::with_label("", "Hazard Ratio"),
+ } |
|||
| 55 | -! | +|||
| 244 | +
- hr_ci = formatters::with_label("", f_conf_level(conf_level)),
+
|
|||
| 56 | -! | +|||
| 245 | +17x |
- n_tot = formatters::with_label("", "Total n"),
+ names(by_grade) <- as.character(seq_along(by_grade)) |
||
| 57 | -! | +|||
| 246 | +
- n_tot_events = formatters::with_label("", "Total events")
+
|
|||
| 58 | +247 |
- )+ # baseline grade less 4 or missing |
||
| 59 | -+ | |||
| 248 | +17x |
- )+ df_temp <- df[!df[[baseline_var]] %in% worst_grade, ] |
||
| 60 | +249 |
- }+ |
||
| 61 | -71x | +|||
| 250 | +
- data <- rbind(.ref_group, df)+ # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction |
|||
| 62 | -71x | +251 | +17x |
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ denom <- length(unique(df_temp[, id, drop = TRUE])) |
| 63 | +252 | |||
| 64 | -71x | +|||
| 253 | +
- df_cox <- data.frame(+ # condition 1: missing baseline and in the direction of abnormality |
|||
| 65 | -71x | +254 | +17x |
- tte = data[[.var]],+ con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade) |
| 66 | -71x | +255 | +17x |
- is_event = data[[is_event]],+ df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ] |
| 67 | -71x | +|||
| 256 | +
- arm = group+ |
|||
| 68 | +257 |
- )+ # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline |
||
| 69 | -71x | +258 | +17x |
- if (is.null(strat)) {
+ if (direction == "Low") {
|
| 70 | -64x | +259 | +10x |
- formula_cox <- survival::Surv(tte, is_event) ~ arm+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
| 71 | +260 |
} else {
|
||
| 72 | +261 | 7x |
- formula_cox <- stats::as.formula(+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
|
| 73 | -7x | +|||
| 262 | +
- paste0(+ } |
|||
| 74 | -7x | +|||
| 263 | +
- "survival::Surv(tte, is_event) ~ arm + strata(",
+
+ |
+ |||
| 264 | ++ |
+ # number of patients satisfy either conditions 1 or 2 |
||
| 75 | -7x | +265 | +17x |
- paste(strat, collapse = ","),+ num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE])) |
| 76 | +266 |
- ")"+ + |
+ ||
| 267 | +17x | +
+ list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
|
||
| 77 | +268 |
- )+ } |
||
| 78 | +269 |
- )+ |
||
| 79 | -7x | +|||
| 270 | +
- df_cox <- cbind(df_cox, data[strat])+ #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline |
|||
| 80 | +271 |
- }+ #' lab grades are worse than their baseline grades. |
||
| 81 | -71x | +|||
| 272 | +
- cox_fit <- survival::coxph(+ #' |
|||
| 82 | -71x | +|||
| 273 | +
- formula = formula_cox,+ #' @return |
|||
| 83 | -71x | +|||
| 274 | +
- data = df_cox,+ #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst |
|||
| 84 | -71x | +|||
| 275 | +
- ties = ties+ #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades |
|||
| 85 | +276 |
- )+ #' "1", "2", "3", "4" and "Any". |
||
| 86 | -71x | +|||
| 277 | +
- sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)+ #' |
|||
| 87 | -71x | +|||
| 278 | +
- orginal_survdiff <- survival::survdiff(+ #' @keywords internal |
|||
| 88 | -71x | +|||
| 279 | +
- formula_cox,+ s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint |
|||
| 89 | -71x | +|||
| 280 | +
- data = df_cox+ .var = "ATOXGR", |
|||
| 90 | +281 |
- )+ variables = list( |
||
| 91 | -71x | +|||
| 282 | +
- log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ id = "USUBJID", |
|||
| 92 | +283 |
-
+ baseline_var = "BTOXGR", |
||
| 93 | -71x | +|||
| 284 | +
- pval <- switch(pval_method,+ direction_var = "GRADDR" |
|||
| 94 | -71x | +|||
| 285 | +
- "wald" = sum_cox$waldtest["pvalue"],+ )) {
|
|||
| 95 | -71x | +286 | +1x |
- "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff()+ checkmate::assert_string(.var) |
| 96 | -71x | +287 | +1x |
- "likelihood" = sum_cox$logtest["pvalue"]+ checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
|
| 97 | -+ | |||
| 288 | +1x |
- )+ checkmate::assert_string(variables$id) |
||
| 98 | -71x | +289 | +1x |
- list(+ checkmate::assert_string(variables$baseline_var) |
| 99 | -71x | +290 | +1x |
- pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
+ checkmate::assert_string(variables$direction_var) |
| 100 | -71x | +291 | +1x |
- hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),+ assert_df_with_variables(df, c(aval = .var, variables[1:3])) |
| 101 | -71x | +292 | +1x |
- hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),+ assert_list_of_variables(variables) |
| 102 | -71x | +|||
| 293 | +
- n_tot = formatters::with_label(sum_cox$n, "Total n"),+ |
|||
| 103 | -71x | +294 | +1x |
- n_tot_events = formatters::with_label(sum_cox$nevent, "Total events")+ h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var) |
| 104 | +295 |
- )+ } |
||
| 105 | +296 |
- }+ |
||
| 106 | +297 | |||
| 107 | +298 |
- #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`.+ #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun` |
||
| 108 | +299 | ++ |
+ #' in `count_abnormal_lab_worsen_by_baseline()`.+ |
+ |
| 300 |
#' |
|||
| 109 | +301 |
#' @return |
||
| 110 | +302 |
- #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with |
||
| 111 | +303 |
- #'+ #' formatted [rtables::CellValue()]. |
||
| 112 | +304 |
- #' @keywords internal+ #' |
||
| 113 | +305 |
- a_coxph_pairwise <- make_afun(+ #' @keywords internal |
||
| 114 | +306 |
- s_coxph_pairwise,+ a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint |
||
| 115 | +307 |
- .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L),+ s_count_abnormal_lab_worsen_by_baseline, |
||
| 116 | +308 |
- .formats = c(+ .formats = c(fraction = format_fraction), |
||
| 117 | +309 |
- pvalue = "x.xxxx | (<0.0001)",+ .ungroup_stats = "fraction" |
||
| 118 | +310 |
- hr = "xx.xx",+ ) |
||
| 119 | +311 |
- hr_ci = "(xx.xx, xx.xx)",+ |
||
| 120 | +312 |
- n_tot = "xx.xx",+ #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function |
||
| 121 | +313 |
- n_tot_events = "xx.xx"+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 122 | +314 |
- )+ #' |
||
| 123 | +315 |
- )+ #' @return |
||
| 124 | +316 |
-
+ #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting |
||
| 125 | +317 |
- #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments+ #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted |
||
| 126 | +318 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout. |
||
| 127 | +319 |
#' |
||
| 128 | +320 |
- #' @return+ #' @examples |
||
| 129 | +321 |
- #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions,+ #' library(dplyr) |
||
| 130 | +322 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 131 | +323 |
- #' the statistics from `s_coxph_pairwise()` to the table layout.+ #' # The direction variable, GRADDR, is based on metadata |
||
| 132 | +324 |
- #'+ #' adlb <- tern_ex_adlb %>% |
||
| 133 | +325 |
- #' @examples+ #' mutate( |
||
| 134 | +326 |
- #' library(dplyr)+ #' GRADDR = case_when( |
||
| 135 | +327 |
- #'+ #' PARAMCD == "ALT" ~ "B", |
||
| 136 | +328 |
- #' adtte_f <- tern_ex_adtte %>%+ #' PARAMCD == "CRP" ~ "L", |
||
| 137 | +329 |
- #' filter(PARAMCD == "OS") %>%+ #' PARAMCD == "IGA" ~ "H" |
||
| 138 | +330 |
- #' mutate(is_event = CNSR == 0)+ #' ) |
||
| 139 | +331 |
- #'+ #' ) %>% |
||
| 140 | +332 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 141 | +333 |
- #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B")+ #' |
||
| 142 | +334 |
- #'+ #' df <- h_adlb_worsen( |
||
| 143 | +335 |
- #' basic_table() %>%+ #' adlb, |
||
| 144 | +336 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 145 | +337 |
- #' add_colcounts() %>%+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 146 | +338 |
- #' coxph_pairwise(+ #' direction_var = "GRADDR" |
||
| 147 | +339 |
- #' vars = "AVAL",+ #' ) |
||
| 148 | +340 |
- #' is_event = "is_event",+ #' |
||
| 149 | +341 |
- #' var_labels = "Unstratified Analysis"+ #' basic_table() %>% |
||
| 150 | +342 |
- #' ) %>%+ #' split_cols_by("ARMCD") %>%
|
||
| 151 | +343 |
- #' build_table(df = adtte_f)+ #' add_colcounts() %>% |
||
| 152 | +344 |
- #'+ #' split_rows_by("PARAMCD") %>%
|
||
| 153 | +345 |
- #' basic_table() %>%+ #' split_rows_by("GRADDR") %>%
|
||
| 154 | +346 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' count_abnormal_lab_worsen_by_baseline( |
||
| 155 | +347 |
- #' add_colcounts() %>%+ #' var = "ATOXGR", |
||
| 156 | +348 |
- #' coxph_pairwise(+ #' variables = list( |
||
| 157 | +349 |
- #' vars = "AVAL",+ #' id = "USUBJID", |
||
| 158 | +350 |
- #' is_event = "is_event",+ #' baseline_var = "BTOXGR", |
||
| 159 | +351 |
- #' var_labels = "Stratified Analysis",+ #' direction_var = "GRADDR" |
||
| 160 | +352 |
- #' strat = "SEX",+ #' ) |
||
| 161 | +353 |
- #' control = control_coxph(pval_method = "wald")+ #' ) %>% |
||
| 162 | +354 |
- #' ) %>%+ #' append_topleft("Direction of Abnormality") %>%
|
||
| 163 | +355 |
- #' build_table(df = adtte_f)+ #' build_table(df = df, alt_counts_df = tern_ex_adsl) |
||
| 164 | +356 |
#' |
||
| 165 | +357 |
#' @export |
||
| 166 | +358 |
#' @order 2 |
||
| 167 | +359 |
- coxph_pairwise <- function(lyt,+ count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint |
||
| 168 | +360 |
- vars,+ var, |
||
| 169 | +361 |
- na_str = default_na_str(),+ variables = list( |
||
| 170 | +362 |
- nested = TRUE,+ id = "USUBJID", |
||
| 171 | +363 |
- ...,+ baseline_var = "BTOXGR", |
||
| 172 | +364 |
- var_labels = "CoxPH",+ direction_var = "GRADDR" |
||
| 173 | +365 |
- show_labels = "visible",+ ), |
||
| 174 | +366 |
- table_names = vars,+ na_str = default_na_str(), |
||
| 175 | +367 |
- .stats = c("pvalue", "hr", "hr_ci"),
+ nested = TRUE, |
||
| 176 | +368 |
- .formats = NULL,+ ..., |
||
| 177 | +369 |
- .labels = NULL,+ table_names = NULL, |
||
| 178 | +370 |
- .indent_mods = NULL) {
+ .stats = NULL,+ |
+ ||
| 371 | ++ |
+ .formats = NULL,+ |
+ ||
| 372 | ++ |
+ .labels = NULL,+ |
+ ||
| 373 | ++ |
+ .indent_mods = NULL) {
|
||
| 179 | -5x | +374 | +1x |
- extra_args <- list(...)+ checkmate::assert_string(var) |
| 180 | +375 | |||
| 181 | -5x | +376 | +1x | +
+ extra_args <- list(variables = variables, ...)+ |
+
| 377 | ++ | + + | +||
| 378 | +1x |
afun <- make_afun( |
||
| 182 | -5x | +379 | +1x |
- a_coxph_pairwise,+ a_count_abnormal_lab_worsen_by_baseline, |
| 183 | -5x | +380 | +1x |
.stats = .stats, |
| 184 | -5x | +381 | +1x |
.formats = .formats, |
| 185 | -5x | +382 | +1x |
.labels = .labels, |
| 186 | -5x | +383 | +1x |
.indent_mods = .indent_mods |
| 187 | +384 |
) |
||
| 188 | -5x | +|||
| 385 | +
- analyze(+ |
|||
| 189 | -5x | +386 | +1x |
- lyt,+ lyt <- analyze( |
| 190 | -5x | +387 | +1x |
- vars,+ lyt = lyt, |
| 191 | -5x | +388 | +1x |
- var_labels = var_labels,+ vars = var, |
| 192 | -5x | +389 | +1x |
- show_labels = show_labels,+ afun = afun, |
| 193 | -5x | +390 | +1x |
- table_names = table_names,+ na_str = na_str, |
| 194 | -5x | +391 | +1x |
- afun = afun,+ nested = nested, |
| 195 | -5x | +392 | +1x |
- na_str = na_str,+ extra_args = extra_args, |
| 196 | -5x | +393 | +1x |
- nested = nested,+ show_labels = "hidden" |
| 197 | -5x | +|||
| 394 | +
- extra_args = extra_args+ ) |
|||
| 198 | +395 |
- )+ + |
+ ||
| 396 | +1x | +
+ lyt |
||
| 199 | +397 |
}@@ -117447,14 +119570,14 @@ tern coverage - 90.46% |
| 1 |
- #' Odds Ratio Estimation+ #' Compare Variables Between Groups |
||
| 5 |
- #' Compares bivariate responses between two groups in terms of odds ratios+ #' Comparison with a reference group for different `x` objects. |
||
| 6 |
- #' along with a confidence interval.+ #' |
||
| 7 |
- #'+ #' @inheritParams argument_convention |
||
| 8 |
- #' @inheritParams split_cols_by_groups+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("analyze_vars_numeric")` to see
|
||
| 9 |
- #' @inheritParams argument_convention+ #' statistics available for numeric variables, and `get_stats("analyze_vars_counts")` for statistics available
|
||
| 10 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_odds_ratio")`
+ #' for non-numeric variables. |
||
| 11 |
- #' to see available statistics for this function.+ #' |
||
| 12 |
- #'+ #' @note |
||
| 13 |
- #' @details This function uses either logistic regression for unstratified+ #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions |
||
| 14 |
- #' analyses, or conditional logistic regression for stratified analyses.+ #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would |
||
| 15 |
- #' The Wald confidence interval with the specified confidence level is+ #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted |
||
| 16 |
- #' calculated.+ #' for as explicit factor levels. |
||
| 17 |
- #'+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
||
| 18 |
- #' @note For stratified analyses, there is currently no implementation for conditional+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
||
| 19 |
- #' likelihood confidence intervals, therefore the likelihood confidence interval is not+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
||
| 20 |
- #' yet available as an option. Besides, when `rsp` contains only responders or non-responders,+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
||
| 21 |
- #' then the result values will be `NA`, because no odds ratio estimation is possible.+ #' * For character variables, automatic conversion to factor does not guarantee that the table |
||
| 22 |
- #'+ #' will be generated correctly. In particular for sparse tables this very likely can fail. |
||
| 23 |
- #' @seealso Relevant helper function [h_odds_ratio()].+ #' Therefore it is always better to manually convert character variables to factors during pre-processing. |
||
| 24 |
- #'+ #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison |
||
| 25 |
- #' @name odds_ratio+ #' is well defined. |
||
| 26 |
- #' @order 1+ #' |
||
| 27 |
- NULL+ #' @seealso Relevant constructor function [create_afun_compare()], [s_summary()] which is used internally |
||
| 28 |
-
+ #' to compute a summary within `s_compare()`, and [a_compare()] which is used (with `compare = TRUE`) as the analysis |
||
| 29 |
- #' @describeIn odds_ratio Statistics function which estimates the odds ratio+ #' function for `compare_vars()`. |
||
| 30 |
- #' between a treatment and a control. A `variables` list with `arm` and `strata`+ #' |
||
| 31 |
- #' variable names must be passed if a stratified analysis is required.+ #' @name compare_variables |
||
| 32 |
- #'+ #' @include analyze_variables.R |
||
| 33 |
- #' @return+ #' @order 1 |
||
| 34 |
- #' * `s_odds_ratio()` returns a named list with the statistics `or_ci`+ NULL |
||
| 35 |
- #' (containing `est`, `lcl`, and `ucl`) and `n_tot`.+ |
||
| 36 |
- #'+ #' @describeIn compare_variables S3 generic function to produce a comparison summary. |
||
| 37 |
- #' @examples+ #' |
||
| 38 |
- #' # Unstratified analysis.+ #' @return |
||
| 39 |
- #' s_odds_ratio(+ #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values. |
||
| 40 |
- #' df = subset(dta, grp == "A"),+ #' |
||
| 41 |
- #' .var = "rsp",+ #' @export |
||
| 42 |
- #' .ref_group = subset(dta, grp == "B"),+ s_compare <- function(x, |
||
| 43 |
- #' .in_ref_col = FALSE,+ .ref_group, |
||
| 44 |
- #' .df_row = dta+ .in_ref_col, |
||
| 45 |
- #' )+ ...) {
|
||
| 46 | -+ | 31x |
- #'+ UseMethod("s_compare", x)
|
| 47 |
- #' # Stratified analysis.+ } |
||
| 48 |
- #' s_odds_ratio(+ |
||
| 49 |
- #' df = subset(dta, grp == "A"),+ #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test |
||
| 50 |
- #' .var = "rsp",+ #' to calculate the p-value. |
||
| 51 |
- #' .ref_group = subset(dta, grp == "B"),+ #' |
||
| 52 |
- #' .in_ref_col = FALSE,+ #' @method s_compare numeric |
||
| 53 |
- #' .df_row = dta,+ #' |
||
| 54 |
- #' variables = list(arm = "grp", strata = "strata")+ #' @examples |
||
| 55 |
- #' )+ #' # `s_compare.numeric` |
||
| 57 |
- #' @export+ #' ## Usual case where both this and the reference group vector have more than 1 value. |
||
| 58 |
- s_odds_ratio <- function(df,+ #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE) |
||
| 59 |
- .var,+ #' |
||
| 60 |
- .ref_group,+ #' ## If one group has not more than 1 value, then p-value is not calculated. |
||
| 61 |
- .in_ref_col,+ #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE) |
||
| 62 |
- .df_row,+ #' |
||
| 63 |
- variables = list(arm = NULL, strata = NULL),+ #' ## Empty numeric does not fail, it returns NA-filled items and no p-value. |
||
| 64 |
- conf_level = 0.95,+ #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE) |
||
| 65 |
- groups_list = NULL) {
+ #' |
||
| 66 | -70x | +
- y <- list(or_ci = "", n_tot = "")+ #' @export |
|
| 67 |
-
+ s_compare.numeric <- function(x, |
||
| 68 | -70x | +
- if (!.in_ref_col) {
+ .ref_group, |
|
| 69 | -70x | +
- assert_proportion_value(conf_level)+ .in_ref_col, |
|
| 70 | -70x | +
- assert_df_with_variables(df, list(rsp = .var))+ ...) {
|
|
| 71 | -70x | +15x |
- assert_df_with_variables(.ref_group, list(rsp = .var))+ checkmate::assert_numeric(x) |
| 72 | -+ | 15x |
-
+ checkmate::assert_numeric(.ref_group) |
| 73 | -70x | +15x |
- if (is.null(variables$strata)) {
+ checkmate::assert_flag(.in_ref_col) |
| 74 | -57x | +
- data <- data.frame(+ |
|
| 75 | -57x | +15x |
- rsp = c(.ref_group[[.var]], df[[.var]]),+ y <- s_summary.numeric(x = x, ...) |
| 76 | -57x | +
- grp = factor(+ |
|
| 77 | -57x | +15x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
|
| 78 | -57x | +11x |
- levels = c("ref", "Not-ref")
+ stats::t.test(x, .ref_group)$p.value |
| 79 |
- )+ } else {
|
||
| 80 | -+ | 4x |
- )+ character() |
| 81 | -57x | +
- y <- or_glm(data, conf_level = conf_level)+ } |
|
| 82 |
- } else {
+
|
||
| 83 | -13x | +15x |
- assert_df_with_variables(.df_row, c(list(rsp = .var), variables))+ y |
| 84 |
-
+ } |
||
| 85 |
- # The group variable prepared for clogit must be synchronised with combination groups definition.+ |
||
| 86 | -13x | +
- if (is.null(groups_list)) {
+ #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test |
|
| 87 | -12x | +
- ref_grp <- as.character(unique(.ref_group[[variables$arm]]))+ #' to calculate the p-value. |
|
| 88 | -12x | +
- trt_grp <- as.character(unique(df[[variables$arm]]))+ #' |
|
| 89 | -12x | +
- grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)+ #' @param denom (`string`)\cr choice of denominator for factor proportions, |
|
| 90 |
- } else {
+ #' can only be `n` (number of values in this row and column intersection). |
||
| 91 |
- # If more than one level in reference col.+ #' |
||
| 92 | -1x | +
- reference <- as.character(unique(.ref_group[[variables$arm]]))+ #' @method s_compare factor |
|
| 93 | -1x | +
- grp_ref_flag <- vapply(+ #' |
|
| 94 | -1x | +
- X = groups_list,+ #' @examples |
|
| 95 | -1x | +
- FUN.VALUE = TRUE,+ #' # `s_compare.factor` |
|
| 96 | -1x | +
- FUN = function(x) all(reference %in% x)+ #' |
|
| 97 |
- )+ #' ## Basic usage: |
||
| 98 | -1x | +
- ref_grp <- names(groups_list)[grp_ref_flag]+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
|
| 99 |
-
+ #' y <- factor(c("a", "b", "c"))
|
||
| 100 |
- # If more than one level in treatment col.+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE) |
||
| 101 | -1x | +
- treatment <- as.character(unique(df[[variables$arm]]))+ #' |
|
| 102 | -1x | +
- grp_trt_flag <- vapply(+ #' ## Management of NA values. |
|
| 103 | -1x | +
- X = groups_list,+ #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
|
|
| 104 | -1x | +
- FUN.VALUE = TRUE,+ #' y <- explicit_na(factor(c("a", "b", "c", NA)))
|
|
| 105 | -1x | +
- FUN = function(x) all(treatment %in% x)+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
|
| 106 |
- )+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
||
| 107 | -1x | +
- trt_grp <- names(groups_list)[grp_trt_flag]+ #' |
|
| 108 |
-
+ #' @export |
||
| 109 | -1x | +
- grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)+ s_compare.factor <- function(x, |
|
| 110 | -1x | +
- grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)+ .ref_group, |
|
| 111 |
- }+ .in_ref_col, |
||
| 112 |
-
+ denom = "n", |
||
| 113 |
- # The reference level in `grp` must be the same as in the `rtables` column split.+ na.rm = TRUE, # nolint |
||
| 114 | -13x | +
- data <- data.frame(+ ...) {
|
|
| 115 | -13x | +12x |
- rsp = .df_row[[.var]],+ checkmate::assert_flag(.in_ref_col) |
| 116 | -13x | +12x |
- grp = grp,+ assert_valid_factor(x) |
| 117 | -13x | +12x |
- strata = interaction(.df_row[variables$strata])+ assert_valid_factor(.ref_group) |
| 118 | -+ | 12x |
- )+ denom <- match.arg(denom) |
| 119 | -13x | +
- y_all <- or_clogit(data, conf_level = conf_level)+ |
|
| 120 | -13x | +12x |
- checkmate::assert_string(trt_grp)+ y <- s_summary.factor( |
| 121 | -13x | +12x |
- checkmate::assert_subset(trt_grp, names(y_all$or_ci))+ x = x, |
| 122 | 12x |
- y$or_ci <- y_all$or_ci[[trt_grp]]+ denom = denom, |
|
| 123 | 12x |
- y$n_tot <- y_all$n_tot+ na.rm = na.rm, |
|
| 124 |
- }+ ... |
||
| 125 |
- }+ ) |
||
| 127 | -69x | +12x |
- y$or_ci <- formatters::with_label(+ if (na.rm) {
|
| 128 | -69x | +12x |
- x = y$or_ci,+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
| 129 | -69x | +12x |
- label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
+ .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
|
| 130 |
- )+ } else {
|
||
| 131 | -+ | ! |
-
+ x <- x %>% explicit_na(label = "NA") |
| 132 | -69x | +! |
- y$n_tot <- formatters::with_label(+ .ref_group <- .ref_group %>% explicit_na(label = "NA") |
| 133 | -69x | +
- x = y$n_tot,+ } |
|
| 134 | -69x | +
- label = "Total n"+ |
|
| 135 | -+ | ! |
- )+ if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
|
| 136 | -+ | 12x |
-
+ checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2) |
| 137 | -69x | +
- y+ |
|
| 138 | -+ | 12x |
- }+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
| 139 | -+ | 9x |
-
+ tab <- rbind(table(x), table(.ref_group)) |
| 140 | -+ | 9x |
- #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`.+ res <- suppressWarnings(stats::chisq.test(tab)) |
| 141 | -+ | 9x |
- #'+ res$p.value |
| 142 |
- #' @return+ } else {
|
||
| 143 | -+ | 3x |
- #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()].+ character() |
| 144 |
- #'+ } |
||
| 145 |
- #' @examples+ |
||
| 146 | -+ | 12x |
- #' a_odds_ratio(+ y |
| 147 |
- #' df = subset(dta, grp == "A"),+ } |
||
| 148 |
- #' .var = "rsp",+ |
||
| 149 |
- #' .ref_group = subset(dta, grp == "B"),+ #' @describeIn compare_variables Method for `character` class. This makes an automatic |
||
| 150 |
- #' .in_ref_col = FALSE,+ #' conversion to `factor` (with a warning) and then forwards to the method for factors. |
||
| 151 |
- #' .df_row = dta+ #' |
||
| 152 |
- #' )+ #' @param verbose (`logical`)\cr Whether warnings and messages should be printed. Mainly used |
||
| 153 |
- #'+ #' to print out information about factor casting. Defaults to `TRUE`. |
||
| 154 |
- #' @export+ #' |
||
| 155 |
- a_odds_ratio <- make_afun(+ #' @method s_compare character |
||
| 156 |
- s_odds_ratio,+ #' |
||
| 157 |
- .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"),+ #' @examples |
||
| 158 |
- .indent_mods = c(or_ci = 1L)+ #' # `s_compare.character` |
||
| 159 |
- )+ #' |
||
| 160 |
-
+ #' ## Basic usage: |
||
| 161 |
- #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments+ #' x <- c("a", "a", "b", "c", "a")
|
||
| 162 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' y <- c("a", "b", "c")
|
||
| 163 |
- #'+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE) |
||
| 164 |
- #' @param ... arguments passed to `s_odds_ratio()`.+ #' |
||
| 165 |
- #'+ #' ## Note that missing values handling can make a large difference: |
||
| 166 |
- #' @return+ #' x <- c("a", "a", "b", "c", "a", NA)
|
||
| 167 |
- #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions,+ #' y <- c("a", "b", "c", rep(NA, 20))
|
||
| 168 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' s_compare(x, |
||
| 169 |
- #' the statistics from `s_odds_ratio()` to the table layout.+ #' .ref_group = y, .in_ref_col = FALSE, |
||
| 170 |
- #'+ #' .var = "x", verbose = FALSE |
||
| 171 |
- #' @examples+ #' ) |
||
| 172 |
- #' set.seed(12)+ #' s_compare(x, |
||
| 173 |
- #' dta <- data.frame(+ #' .ref_group = y, .in_ref_col = FALSE, .var = "x", |
||
| 174 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ #' na.rm = FALSE, verbose = FALSE |
||
| 175 |
- #' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
+ #' ) |
||
| 176 |
- #' strata = factor(sample(c("C", "D"), 100, TRUE))
+ #' |
||
| 177 |
- #' )+ #' @export |
||
| 178 |
- #'+ s_compare.character <- function(x, |
||
| 179 |
- #' l <- basic_table() %>%+ .ref_group, |
||
| 180 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ .in_ref_col, |
||
| 181 |
- #' estimate_odds_ratio(vars = "rsp")+ denom = "n", |
||
| 182 |
- #'+ na.rm = TRUE, # nolint |
||
| 183 |
- #' build_table(l, df = dta)+ .var, |
||
| 184 |
- #'+ verbose = TRUE, |
||
| 185 |
- #' @export+ ...) {
|
||
| 186 | -+ | 1x |
- #' @order 2+ x <- as_factor_keep_attributes(x, verbose = verbose) |
| 187 | -+ | 1x |
- estimate_odds_ratio <- function(lyt,+ .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose) |
| 188 | -+ | 1x |
- vars,+ s_compare( |
| 189 | -+ | 1x |
- variables = list(arm = NULL, strata = NULL),+ x = x, |
| 190 | -+ | 1x |
- conf_level = 0.95,+ .ref_group = .ref_group, |
| 191 | -+ | 1x |
- groups_list = NULL,+ .in_ref_col = .in_ref_col, |
| 192 | -+ | 1x |
- na_str = default_na_str(),+ denom = denom, |
| 193 | -+ | 1x |
- nested = TRUE,+ na.rm = na.rm, |
| 194 |
- ...,+ ... |
||
| 195 |
- show_labels = "hidden",+ ) |
||
| 196 |
- table_names = vars,+ } |
||
| 197 |
- .stats = "or_ci",+ |
||
| 198 |
- .formats = NULL,+ #' @describeIn compare_variables Method for `logical` class. A chi-squared test |
||
| 199 |
- .labels = NULL,+ #' is used. If missing values are not removed, then they are counted as `FALSE`. |
||
| 200 |
- .indent_mods = NULL) {
+ #' |
||
| 201 | -4x | +
- extra_args <- list(variables = variables, conf_level = conf_level, groups_list = groups_list, ...)+ #' @method s_compare logical |
|
| 202 |
-
+ #' |
||
| 203 | -4x | +
- afun <- make_afun(+ #' @examples |
|
| 204 | -4x | +
- a_odds_ratio,+ #' # `s_compare.logical` |
|
| 205 | -4x | +
- .stats = .stats,+ #' |
|
| 206 | -4x | +
- .formats = .formats,+ #' ## Basic usage: |
|
| 207 | -4x | +
- .labels = .labels,+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
|
| 208 | -4x | +
- .indent_mods = .indent_mods+ #' y <- c(FALSE, FALSE, TRUE) |
|
| 209 |
- )+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE) |
||
| 210 |
-
+ #' |
||
| 211 | -4x | +
- analyze(+ #' ## Management of NA values. |
|
| 212 | -4x | +
- lyt,+ #' x <- c(NA, TRUE, FALSE) |
|
| 213 | -4x | +
- vars,+ #' y <- c(NA, NA, NA, NA, FALSE) |
|
| 214 | -4x | +
- afun = afun,+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
|
| 215 | -4x | +
- na_str = na_str,+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
|
| 216 | -4x | +
- nested = nested,+ #' |
|
| 217 | -4x | +
- extra_args = extra_args,+ #' @export |
|
| 218 | -4x | +
- show_labels = show_labels,+ s_compare.logical <- function(x, |
|
| 219 | -4x | +
- table_names = table_names+ .ref_group, |
|
| 220 |
- )+ .in_ref_col, |
||
| 221 |
- }+ na.rm = TRUE, # nolint |
||
| 222 |
-
+ denom = "n", |
||
| 223 |
- #' Helper Functions for Odds Ratio Estimation+ ...) {
|
||
| 224 | -+ | 3x |
- #'+ denom <- match.arg(denom) |
| 225 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 226 | -+ | 3x |
- #'+ y <- s_summary.logical( |
| 227 | -+ | 3x |
- #' Functions to calculate odds ratios in [estimate_odds_ratio()].+ x = x, |
| 228 | -+ | 3x |
- #'+ na.rm = na.rm, |
| 229 | -+ | 3x |
- #' @inheritParams argument_convention+ denom = denom, |
| 230 |
- #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally+ ... |
||
| 231 |
- #' `strata` for [or_clogit()].+ ) |
||
| 232 |
- #'+ |
||
| 233 | -+ | 3x |
- #' @return A named `list` of elements `or_ci` and `n_tot`.+ if (na.rm) {
|
| 234 | -+ | 2x |
- #'+ x <- stats::na.omit(x) |
| 235 | -+ | 2x |
- #' @seealso [odds_ratio]+ .ref_group <- stats::na.omit(.ref_group) |
| 236 |
- #'+ } else {
|
||
| 237 | -+ | 1x |
- #' @name h_odds_ratio+ x[is.na(x)] <- FALSE |
| 238 | -+ | 1x |
- NULL+ .ref_group[is.na(.ref_group)] <- FALSE |
| 239 |
-
+ } |
||
| 240 |
- #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be+ |
||
| 241 | -+ | 3x |
- #' exactly 2 groups in `data` as specified by the `grp` variable.+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
| 242 | -+ | 3x |
- #'+ x <- factor(x, levels = c(TRUE, FALSE)) |
| 243 | -+ | 3x |
- #' @examples+ .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE)) |
| 244 | -+ | 3x |
- #' # Data with 2 groups.+ tbl <- rbind(table(x), table(.ref_group)) |
| 245 | -+ | 3x |
- #' data <- data.frame(+ suppressWarnings(prop_chisq(tbl)) |
| 246 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),+ } else {
|
||
| 247 | -+ | ! |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],+ character() |
| 248 |
- #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],+ } |
||
| 249 |
- #' stringsAsFactors = TRUE+ |
||
| 250 | -+ | 3x |
- #' )+ y |
| 251 |
- #'+ } |
||
| 252 |
- #' # Odds ratio based on glm.+ |
||
| 253 |
- #' or_glm(data, conf_level = 0.95)+ #' @describeIn compare_variables Formatted analysis function which is used as `afun` |
||
| 254 |
- #'+ #' in `compare_vars()`. |
||
| 255 |
- #' @export+ #' |
||
| 256 |
- or_glm <- function(data, conf_level) {
+ #' @return |
||
| 257 | -62x | +
- checkmate::assert_logical(data$rsp)+ #' * `a_compare()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 258 | -62x | +
- assert_proportion_value(conf_level)+ #' |
|
| 259 | -62x | +
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))+ #' @note `a_compare()` has been deprecated in favor of `a_summary()` with argument `compare` set to `TRUE`. |
|
| 260 | -62x | +
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ #' |
|
| 261 |
-
+ #' @examples |
||
| 262 | -62x | +
- data$grp <- as_factor_keep_attributes(data$grp)+ #' # `a_compare` deprecated - use `a_summary()` instead |
|
| 263 | -62x | +
- assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)+ #' a_compare(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .stats = c("n", "pval"))
|
|
| 264 | -62x | +
- formula <- stats::as.formula("rsp ~ grp")
+ #' |
|
| 265 | -62x | +
- model_fit <- stats::glm(+ #' @export |
|
| 266 | -62x | +
- formula = formula, data = data,+ a_compare <- function(x, |
|
| 267 | -62x | +
- family = stats::binomial(link = "logit")+ .N_col, # nolint |
|
| 268 |
- )+ .N_row, # nolint |
||
| 269 |
-
+ .var = NULL, |
||
| 270 |
- # Note that here we need to discard the intercept.+ .df_row = NULL, |
||
| 271 | -62x | +
- or <- exp(stats::coef(model_fit)[-1])+ .ref_group = NULL, |
|
| 272 | -62x | +
- or_ci <- exp(+ .in_ref_col = FALSE, |
|
| 273 | -62x | +
- stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE]+ ...) {
|
|
| 274 | -+ | 1x |
- )+ lifecycle::deprecate_warn( |
| 275 | -+ | 1x |
-
+ "0.8.3", |
| 276 | -62x | +1x |
- values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
+ "a_compare()", |
| 277 | -62x | +1x |
- n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")+ details = "Please use a_summary() with argument `compare` set to TRUE instead." |
| 278 |
-
+ ) |
||
| 279 | -62x | +1x |
- list(or_ci = values, n_tot = n_tot)+ a_summary( |
| 280 | -+ | 1x |
- }+ x = x, |
| 281 | -+ | 1x |
-
+ .N_col = .N_col, |
| 282 | -+ | 1x |
- #' @describeIn h_odds_ratio estimates the odds ratio based on [survival::clogit()]. This is done for+ .N_row = .N_row, |
| 283 | -+ | 1x |
- #' the whole data set including all groups, since the results are not the same as when doing+ .var = .var, |
| 284 | -+ | 1x |
- #' pairwise comparisons between the groups.+ .df_row = .df_row, |
| 285 | -+ | 1x |
- #'+ .ref_group = .ref_group, |
| 286 | -+ | 1x |
- #' @examples+ .in_ref_col = .in_ref_col, |
| 287 | -+ | 1x |
- #' # Data with 3 groups.+ compare = TRUE, |
| 288 |
- #' data <- data.frame(+ ... |
||
| 289 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),+ ) |
||
| 290 |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],+ } |
||
| 291 |
- #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],+ |
||
| 292 |
- #' stringsAsFactors = TRUE+ #' Constructor Function for [compare_vars()] |
||
| 293 |
- #' )+ #' |
||
| 294 |
- #'+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 295 |
- #' # Odds ratio based on stratified estimation by conditional logistic regression.+ #' |
||
| 296 |
- #' or_clogit(data, conf_level = 0.95)+ #' Constructor function which creates a combined formatted analysis function. |
||
| 298 |
- #' @export+ #' @inheritParams argument_convention |
||
| 299 |
- or_clogit <- function(data, conf_level) {
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 300 | -16x | +
- checkmate::assert_logical(data$rsp)+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|
| 301 | -16x | +
- assert_proportion_value(conf_level)+ #' for that statistic's row label. |
|
| 302 | -16x | +
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))+ #' |
|
| 303 | -16x | +
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ #' @return Combined formatted analysis function for use in [compare_vars()]. |
|
| 304 | -16x | +
- checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
+ #' |
|
| 305 |
-
+ #' @note This function has been deprecated in favor of direct implementation of `a_summary()` with argument `compare` |
||
| 306 | -16x | +
- data$grp <- as_factor_keep_attributes(data$grp)+ #' set to `TRUE`. |
|
| 307 | -16x | +
- data$strata <- as_factor_keep_attributes(data$strata)+ #' |
|
| 308 |
-
+ #' @seealso [compare_vars()] |
||
| 309 |
- # Deviation from convention: `survival::strata` must be simply `strata`.+ #' |
||
| 310 | -16x | +
- formula <- stats::as.formula("rsp ~ grp + strata(strata)")
+ #' @export |
|
| 311 | -16x | +
- model_fit <- clogit_with_tryCatch(formula = formula, data = data)+ create_afun_compare <- function(.stats = NULL, |
|
| 312 |
-
+ .formats = NULL, |
||
| 313 |
- # Create a list with one set of OR estimates and CI per coefficient, i.e.+ .labels = NULL, |
||
| 314 |
- # comparison of one group vs. the reference group.+ .indent_mods = NULL) {
|
||
| 315 | -16x | +1x |
- coef_est <- stats::coef(model_fit)+ lifecycle::deprecate_warn( |
| 316 | -16x | +1x |
- ci_est <- stats::confint(model_fit, level = conf_level)+ "0.8.5.9010", |
| 317 | -16x | +1x |
- or_ci <- list()+ "create_afun_compare()", |
| 318 | -16x | +1x |
- for (coef_name in names(coef_est)) {
+ details = "Please use a_summary(compare = TRUE) directly instead." |
| 319 | -18x | +
- grp_name <- gsub("^grp", "", x = coef_name)
+ ) |
|
| 320 | -18x | +1x |
- or_ci[[grp_name]] <- stats::setNames(+ function(x, |
| 321 | -18x | +1x |
- object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])),+ .ref_group, |
| 322 | -18x | +1x |
- nm = c("est", "lcl", "ucl")
+ .in_ref_col, |
| 323 |
- )+ ..., |
||
| 324 | -+ | 1x |
- }+ .var) {
|
| 325 | -16x | +! |
- list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n))+ a_summary(x, |
| 326 | -- |
- }- |
-
| 1 | -- |
- #' Tabulate Biomarker Effects on Binary Response by Subgroup- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -+ | ! |
- #' Tabulate the estimated effects of multiple continuous biomarker variables+ compare = TRUE, |
|
| 6 | -+ | |||
| 327 | +! |
- #' on a binary response endpoint across population subgroups.+ .stats = .stats, |
||
| 7 | -+ | |||
| 328 | +! |
- #'+ .formats = .formats, |
||
| 8 | -+ | |||
| 329 | +! |
- #' @inheritParams argument_convention+ .labels = .labels, |
||
| 9 | -+ | |||
| 330 | +! |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ .indent_mods = .indent_mods, |
||
| 10 | -+ | |||
| 331 | +! |
- #' [extract_rsp_biomarkers()].+ .ref_group = .ref_group, |
||
| 11 | -+ | |||
| 332 | +! |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ .in_ref_col = .in_ref_col, |
||
| 12 | -+ | |||
| 333 | +! |
- #' * `n_tot`: Total number of patients per group.+ .var = .var, ... |
||
| 13 | +334 |
- #' * `n_rsp`: Total number of responses per group.+ ) |
||
| 14 | +335 |
- #' * `prop`: Total response proportion per group.+ } |
||
| 15 | +336 |
- #' * `or`: Odds ratio.+ } |
||
| 16 | +337 |
- #' * `ci`: Confidence interval of odds ratio.+ |
||
| 17 | +338 |
- #' * `pval`: p-value of the effect.+ #' @describeIn compare_variables Layout-creating function which can take statistics function arguments |
||
| 18 | +339 |
- #' Note, the statistics `n_tot`, `or` and `ci` are required.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 19 | +340 |
#' |
||
| 20 | +341 |
- #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup.+ #' @param ... arguments passed to `s_compare()`. |
||
| 21 | +342 |
- #'+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 22 | +343 |
- #' @details These functions create a layout starting from a data frame which contains+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 23 | +344 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ #' for that statistic's row label. |
||
| 24 | +345 |
#' |
||
| 25 | -- |
- #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does- |
- ||
| 26 | +346 |
- #' not start from an input layout `lyt`. This is because internally the table is+ #' @return |
||
| 27 | +347 |
- #' created by combining multiple subtables.+ #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions, |
||
| 28 | +348 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 29 | +349 |
- #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].+ #' the statistics from `s_compare()` to the table layout. |
||
| 30 | +350 |
#' |
||
| 31 | +351 |
#' @examples |
||
| 32 | -- |
- #' library(dplyr)- |
- ||
| 33 | +352 |
- #' library(forcats)+ #' # `compare_vars()` in `rtables` pipelines |
||
| 34 | +353 |
#' |
||
| 35 | -- |
- #' adrs <- tern_ex_adrs- |
- ||
| 36 | -- |
- #' adrs_labels <- formatters::var_labels(adrs)- |
- ||
| 37 | +354 |
- #'+ #' ## Default output within a `rtables` pipeline. |
||
| 38 | +355 |
- #' adrs_f <- adrs %>%+ #' lyt <- basic_table() %>% |
||
| 39 | +356 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
|
||
| 40 | +357 |
- #' mutate(rsp = AVALC == "CR")+ #' compare_vars(c("AGE", "SEX"))
|
||
| 41 | +358 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' build_table(lyt, tern_ex_adsl) |
||
| 42 | +359 |
#' |
||
| 43 | -- |
- #' df <- extract_rsp_biomarkers(- |
- ||
| 44 | -- |
- #' variables = list(- |
- ||
| 45 | -- |
- #' rsp = "rsp",- |
- ||
| 46 | +360 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' ## Select and format statistics output. |
||
| 47 | +361 |
- #' covariates = "SEX",+ #' lyt <- basic_table() %>% |
||
| 48 | +362 |
- #' subgroups = "BMRKR2"+ #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
|
||
| 49 | +363 |
- #' ),+ #' compare_vars( |
||
| 50 | +364 |
- #' data = adrs_f+ #' vars = "AGE", |
||
| 51 | +365 |
- #' )+ #' .stats = c("mean_sd", "pval"),
|
||
| 52 | +366 |
- #'+ #' .formats = c(mean_sd = "xx.x, xx.x"), |
||
| 53 | +367 |
- #' \donttest{
+ #' .labels = c(mean_sd = "Mean, SD") |
||
| 54 | +368 |
- #' ## Table with default columns.+ #' ) |
||
| 55 | +369 |
- #' tabulate_rsp_biomarkers(df)+ #' build_table(lyt, df = tern_ex_adsl) |
||
| 56 | +370 |
#' |
||
| 57 | +371 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ #' @export |
||
| 58 | +372 |
- #' tab <- tabulate_rsp_biomarkers(+ #' @order 2 |
||
| 59 | +373 |
- #' df = df,+ compare_vars <- function(lyt, |
||
| 60 | +374 |
- #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
+ vars, |
||
| 61 | +375 |
- #' )+ var_labels = vars, |
||
| 62 | +376 |
- #'+ na_level = lifecycle::deprecated(), |
||
| 63 | +377 |
- #' ## Finally produce the forest plot.+ na_str = default_na_str(), |
||
| 64 | +378 |
- #' g_forest(tab, xlim = c(0.7, 1.4))+ nested = TRUE, |
||
| 65 | +379 |
- #' }+ ..., |
||
| 66 | +380 |
- #'+ na.rm = TRUE, # nolint |
||
| 67 | +381 |
- #' @export+ show_labels = "default", |
||
| 68 | +382 |
- #' @name response_biomarkers_subgroups+ table_names = vars, |
||
| 69 | +383 |
- tabulate_rsp_biomarkers <- function(df,+ section_div = NA_character_, |
||
| 70 | +384 |
- vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ .stats = c("n", "mean_sd", "count_fraction", "pval"),
|
||
| 71 | +385 |
- na_str = default_na_str(),+ .formats = NULL, |
||
| 72 | +386 |
- .indent_mods = 0L) {
+ .labels = NULL, |
||
| 73 | -4x | +|||
| 387 | +
- checkmate::assert_data_frame(df)+ .indent_mods = NULL) {
|
|||
| 74 | +388 | 4x |
- checkmate::assert_character(df$biomarker)+ if (lifecycle::is_present(na_level)) {
|
|
| 75 | -4x | +|||
| 389 | +! |
- checkmate::assert_character(df$biomarker_label)+ lifecycle::deprecate_warn("0.9.1", "compare_vars(na_level)", "compare_vars(na_str)")
|
||
| 76 | -4x | +|||
| 390 | +! |
- checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
+ na_str <- na_level |
||
| 77 | +391 |
-
+ } |
||
| 78 | -4x | +|||
| 392 | +
- df_subs <- split(df, f = df$biomarker)+ |
|||
| 79 | +393 | 4x |
- tabs <- lapply(df_subs, FUN = function(df_sub) {
- |
- |
| 80 | -7x | -
- tab_sub <- h_tab_rsp_one_biomarker(- |
- ||
| 81 | -7x | -
- df = df_sub,- |
- ||
| 82 | -7x | -
- vars = vars,+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...) |
||
| 83 | -7x | +394 | +1x |
- na_str = na_str,+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
| 84 | -7x | +395 | +1x |
- .indent_mods = .indent_mods+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
| 85 | -+ | |||
| 396 | +! |
- )+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
||
| 86 | +397 |
- # Insert label row as first row in table.+ |
||
| 87 | -7x | +398 | +4x |
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ analyze( |
| 88 | -7x | -
- tab_sub- |
- ||
| 89 | -+ | 399 | +4x |
- })+ lyt = lyt, |
| 90 | +400 | 4x |
- result <- do.call(rbind, tabs)- |
- |
| 91 | -- |
-
+ vars = vars, |
||
| 92 | +401 | 4x |
- n_id <- grep("n_tot", vars)
+ var_labels = var_labels, |
|
| 93 | +402 | 4x |
- or_id <- match("or", vars)
+ afun = a_summary, |
|
| 94 | +403 | 4x |
- ci_id <- match("ci", vars)
+ na_str = na_str, |
|
| 95 | +404 | 4x |
- structure(+ nested = nested, |
|
| 96 | +405 | 4x |
- result,+ extra_args = extra_args, |
|
| 97 | +406 | 4x |
- forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
+ inclNAs = TRUE, |
|
| 98 | +407 | 4x |
- col_x = or_id,+ show_labels = show_labels, |
|
| 99 | +408 | 4x |
- col_ci = ci_id,+ table_names = table_names, |
|
| 100 | +409 | 4x |
- col_symbol_size = n_id+ section_div = section_div |
|
| 101 | +410 |
) |
||
| 102 | +411 |
} |
| 103 | -- | - - | -||
| 104 | +1 |
- #' Prepares Response Data Estimates for Multiple Biomarkers in a Single Data Frame+ #' Helper Function for Deriving Analysis Datasets for `LBT13` and `LBT14` |
||
| 105 | +2 |
#' |
||
| 106 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 107 | +4 |
#' |
||
| 108 | +5 |
- #' Prepares estimates for number of responses, patients and overall response rate,+ #' Helper function that merges `ADSL` and `ADLB` datasets so that missing lab test records are inserted in the |
||
| 109 | +6 |
- #' as well as odds ratio estimates, confidence intervals and p-values,+ #' output dataset. Remember that `na_level` must match the needed pre-processing |
||
| 110 | +7 |
- #' for multiple biomarkers across population subgroups in a single data frame.+ #' done with [df_explicit_na()] to have the desired output. |
||
| 111 | +8 |
- #' `variables` corresponds to the names of variables found in `data`, passed as a+ #' |
||
| 112 | +9 |
- #' named list and requires elements `rsp` and `biomarkers` (vector of continuous+ #' @param adsl (`data.frame`)\cr `ADSL` dataframe. |
||
| 113 | +10 |
- #' biomarker variables) and optionally `covariates`, `subgroups` and `strat`.+ #' @param adlb (`data.frame`)\cr `ADLB` dataframe. |
||
| 114 | +11 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' @param worst_flag (named `vector`)\cr Worst post-baseline lab flag variable. |
||
| 115 | +12 |
- #'+ #' @param by_visit (`logical`)\cr defaults to `FALSE` to generate worst grade per patient. |
||
| 116 | +13 |
- #' @inheritParams argument_convention+ #' If worst grade per patient per visit is specified for `worst_flag`, then |
||
| 117 | +14 |
- #' @inheritParams response_subgroups+ #' `by_visit` should be `TRUE` to generate worst grade patient per visit. |
||
| 118 | +15 |
- #' @param control (named `list`)\cr controls for the response definition and the+ #' @param no_fillin_visits (named `character`)\cr Visits that are not considered for post-baseline worst toxicity |
||
| 119 | +16 |
- #' confidence level produced by [control_logistic()].+ #' grade. Defaults to `c("SCREENING", "BASELINE")`.
|
||
| 120 | +17 |
#' |
||
| 121 | +18 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`,+ #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`, |
||
| 122 | +19 |
- #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when |
||
| 123 | +20 |
- #' `var_label`, and `row_type`.+ #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
|
||
| 124 | +21 |
#' |
||
| 125 | +22 |
- #' @note You can also specify a continuous variable in `rsp` and then use the+ #' @details In the result data missing records will be created for the following situations: |
||
| 126 | +23 |
- #' `response_definition` control to convert that internally to a logical+ #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline). |
||
| 127 | +24 |
- #' variable reflecting binary response.+ #' * Patients who do not have any post-baseline lab values. |
||
| 128 | +25 |
- #'+ #' * Patients without any post-baseline values flagged as the worst. |
||
| 129 | +26 |
- #' @seealso [h_logistic_mult_cont_df()] which is used internally.+ #' |
||
| 130 | +27 |
- #'+ #' @examples |
||
| 131 | +28 |
- #' @examples+ #' # `h_adsl_adlb_merge_using_worst_flag` |
||
| 132 | +29 |
- #' library(dplyr)+ #' adlb_out <- h_adsl_adlb_merge_using_worst_flag( |
||
| 133 | +30 |
- #' library(forcats)+ #' tern_ex_adsl, |
||
| 134 | +31 |
- #'+ #' tern_ex_adlb, |
||
| 135 | +32 |
- #' adrs <- tern_ex_adrs+ #' worst_flag = c("WGRHIFL" = "Y")
|
||
| 136 | +33 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' ) |
||
| 137 | +34 |
#' |
||
| 138 | +35 |
- #' adrs_f <- adrs %>%+ #' # `h_adsl_adlb_merge_using_worst_flag` by visit example |
||
| 139 | +36 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag( |
||
| 140 | +37 |
- #' mutate(rsp = AVALC == "CR")+ #' tern_ex_adsl, |
||
| 141 | +38 |
- #'+ #' tern_ex_adlb, |
||
| 142 | +39 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ #' worst_flag = c("WGRLOVFL" = "Y"),
|
||
| 143 | +40 |
- #' # in logistic regression models with one covariate `RACE`. The subgroups+ #' by_visit = TRUE |
||
| 144 | +41 |
- #' # are defined by the levels of `BMRKR2`.+ #' ) |
||
| 145 | +42 |
- #' df <- extract_rsp_biomarkers(+ #' |
||
| 146 | +43 |
- #' variables = list(+ #' @export |
||
| 147 | +44 |
- #' rsp = "rsp",+ h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint |
||
| 148 | +45 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ adlb, |
||
| 149 | +46 |
- #' covariates = "SEX",+ worst_flag = c("WGRHIFL" = "Y"),
|
||
| 150 | +47 |
- #' subgroups = "BMRKR2"+ by_visit = FALSE, |
||
| 151 | +48 |
- #' ),+ no_fillin_visits = c("SCREENING", "BASELINE")) {
|
||
| 152 | -+ | |||
| 49 | +5x |
- #' data = adrs_f+ col_names <- names(worst_flag) |
||
| 153 | -+ | |||
| 50 | +5x |
- #' )+ filter_values <- worst_flag |
||
| 154 | +51 |
- #' df+ |
||
| 155 | -+ | |||
| 52 | +5x |
- #'+ temp <- Map( |
||
| 156 | -+ | |||
| 53 | +5x |
- #' # Here we group the levels of `BMRKR2` manually, and we add a stratification+ function(x, y) which(adlb[[x]] == y), |
||
| 157 | -+ | |||
| 54 | +5x |
- #' # variable `STRATA1`. We also here use a continuous variable `EOSDY`+ col_names, |
||
| 158 | -+ | |||
| 55 | +5x |
- #' # which is then binarized internally (response is defined as this variable+ filter_values |
||
| 159 | +56 |
- #' # being larger than 750).+ ) |
||
| 160 | +57 |
- #' df_grouped <- extract_rsp_biomarkers(+ |
||
| 161 | -+ | |||
| 58 | +5x |
- #' variables = list(+ position_satisfy_filters <- Reduce(intersect, temp) |
||
| 162 | +59 |
- #' rsp = "EOSDY",+ |
||
| 163 | -+ | |||
| 60 | +5x |
- #' biomarkers = c("BMRKR1", "AGE"),
+ adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb)) |
||
| 164 | -+ | |||
| 61 | +5x |
- #' covariates = "SEX",+ columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
|
||
| 165 | +62 |
- #' subgroups = "BMRKR2",+ |
||
| 166 | -+ | |||
| 63 | +5x |
- #' strat = "STRATA1"+ adlb_f <- adlb[position_satisfy_filters, ] %>% |
||
| 167 | -+ | |||
| 64 | +5x |
- #' ),+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) |
||
| 168 | -+ | |||
| 65 | +5x |
- #' data = adrs_f,+ adlb_f <- adlb_f[, columns_from_adlb] |
||
| 169 | +66 |
- #' groups_lists = list(+ |
||
| 170 | -+ | |||
| 67 | +5x |
- #' BMRKR2 = list(+ avisits_grid <- adlb %>% |
||
| 171 | -+ | |||
| 68 | +5x |
- #' "low" = "LOW",+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>% |
||
| 172 | -+ | |||
| 69 | +5x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ dplyr::pull(.data[["AVISIT"]]) %>% |
||
| 173 | -+ | |||
| 70 | +5x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ unique() |
||
| 174 | +71 |
- #' )+ |
||
| 175 | -+ | |||
| 72 | +5x |
- #' ),+ if (by_visit) {
|
||
| 176 | -+ | |||
| 73 | +1x |
- #' control = control_logistic(+ adsl_lb <- expand.grid( |
||
| 177 | -+ | |||
| 74 | +1x |
- #' response_definition = "I(response > 750)"+ USUBJID = unique(adsl$USUBJID), |
||
| 178 | -+ | |||
| 75 | +1x |
- #' )+ AVISIT = avisits_grid, |
||
| 179 | -+ | |||
| 76 | +1x |
- #' )+ PARAMCD = unique(adlb$PARAMCD) |
||
| 180 | +77 |
- #' df_grouped+ ) |
||
| 181 | +78 |
- #'+ |
||
| 182 | -+ | |||
| 79 | +1x |
- #' @export+ adsl_lb <- adsl_lb %>% |
||
| 183 | -+ | |||
| 80 | +1x |
- extract_rsp_biomarkers <- function(variables,+ dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
|
||
| 184 | -+ | |||
| 81 | +1x |
- data,+ dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
||
| 185 | +82 |
- groups_lists = list(),+ + |
+ ||
| 83 | +1x | +
+ adsl1 <- adsl[, adsl_adlb_common_columns]+ |
+ ||
| 84 | +1x | +
+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
||
| 186 | +85 |
- control = control_logistic(),+ + |
+ ||
| 86 | +1x | +
+ by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
|
||
| 187 | +87 |
- label_all = "All Patients") {
+
|
||
| 188 | -5x | +88 | +1x |
- assert_list_of_variables(variables)+ adlb_btoxgr <- adlb %>% |
| 189 | -5x | +89 | +1x |
- checkmate::assert_string(variables$rsp)+ dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
|
| 190 | -5x | +90 | +1x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ unique() %>% |
| 191 | -5x | +91 | +1x |
- checkmate::assert_string(label_all)+ dplyr::rename("BTOXGR_MAP" = "BTOXGR")
|
| 192 | +92 | |||
| 193 | -+ | |||
| 93 | +1x |
- # Start with all patients.+ adlb_out <- merge( |
||
| 194 | -5x | +94 | +1x |
- result_all <- h_logistic_mult_cont_df(+ adlb_f, |
| 195 | -5x | +95 | +1x |
- variables = variables,+ adsl_lb, |
| 196 | -5x | +96 | +1x |
- data = data,+ by = by_variables_from_adlb, |
| 197 | -5x | +97 | +1x |
- control = control+ all = TRUE,+ |
+
| 98 | +1x | +
+ sort = FALSE |
||
| 198 | +99 |
- )+ ) |
||
| 199 | -5x | +100 | +1x |
- result_all$subgroup <- label_all+ adlb_out <- adlb_out %>% |
| 200 | -5x | +101 | +1x |
- result_all$var <- "ALL"+ dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
|
| 201 | -5x | +102 | +1x |
- result_all$var_label <- label_all+ dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>% |
| 202 | -5x | +103 | +1x |
- result_all$row_type <- "content"+ dplyr::select(-"BTOXGR_MAP")+ |
+
| 104 | ++ | + | ||
| 203 | -5x | +105 | +1x |
- if (is.null(variables$subgroups)) {
+ adlb_var_labels <- c( |
| 204 | -+ | |||
| 106 | +1x |
- # Only return result for all patients.+ formatters::var_labels(adlb[by_variables_from_adlb]), |
||
| 205 | +107 | 1x |
- result_all+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ |
+ |
| 108 | +1x | +
+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
||
| 206 | +109 |
- } else {
+ ) |
||
| 207 | +110 |
- # Add subgroups results.+ } else {
|
||
| 208 | +111 | 4x |
- l_data <- h_split_by_subgroups(+ adsl_lb <- expand.grid( |
|
| 209 | +112 | 4x |
- data,+ USUBJID = unique(adsl$USUBJID), |
|
| 210 | +113 | 4x |
- variables$subgroups,+ PARAMCD = unique(adlb$PARAMCD)+ |
+ |
| 114 | ++ |
+ )+ |
+ ||
| 115 | ++ | + | ||
| 211 | +116 | 4x |
- groups_lists = groups_lists+ adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
|
| 212 | +117 |
- )+ |
||
| 213 | +118 | 4x |
- l_result <- lapply(l_data, function(grp) {
+ adsl1 <- adsl[, adsl_adlb_common_columns] |
|
| 214 | -20x | +119 | +4x |
- result <- h_logistic_mult_cont_df(+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ |
+
| 120 | ++ | + | ||
| 215 | -20x | +121 | +4x |
- variables = variables,+ by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
+ |
+
| 122 | ++ | + | ||
| 216 | -20x | +123 | +4x |
- data = grp$df,+ adlb_out <- merge( |
| 217 | -20x | +124 | +4x |
- control = control+ adlb_f, |
| 218 | -+ | |||
| 125 | +4x |
- )+ adsl_lb, |
||
| 219 | -20x | +126 | +4x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ by = by_variables_from_adlb, |
| 220 | -20x | +127 | +4x |
- cbind(result, result_labels)+ all = TRUE,+ |
+
| 128 | +4x | +
+ sort = FALSE |
||
| 221 | +129 |
- })+ ) |
||
| 222 | -4x | +|||
| 130 | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
|||
| 223 | +131 | 4x |
- result_subgroups$row_type <- "analysis"+ adlb_var_labels <- c( |
|
| 224 | +132 | 4x |
- rbind(+ formatters::var_labels(adlb[by_variables_from_adlb]), |
|
| 225 | +133 | 4x |
- result_all,+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]), |
|
| 226 | +134 | 4x |
- result_subgroups+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
|
| 227 | +135 |
) |
||
| 228 | +136 |
} |
||
| 229 | +137 | ++ | + + | +|
| 138 | +5x | +
+ adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ |
+ ||
| 139 | +5x | +
+ adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ |
+ ||
| 140 | ++ | + + | +||
| 141 | +5x | +
+ formatters::var_labels(adlb_out) <- adlb_var_labels+ |
+ ||
| 142 | ++ | + + | +||
| 143 | +5x | +
+ adlb_out+ |
+ ||
| 144 |
}@@ -124731,14 +126854,14 @@ tern coverage - 90.46% |
| 1 |
- #' Incidence Rate+ #' Convert `rtable` object to `ggplot` object |
|||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 5 |
- #' Estimate the event rate adjusted for person-years at risk, otherwise known+ #' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using |
|||
| 6 |
- #' as incidence rate. Primary analysis variable is the person-years at risk.+ #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored. |
|||
| 8 |
- #' @inheritParams argument_convention+ #' @param tbl (`rtable`)\cr a `rtable` object. |
|||
| 9 |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ #' @param fontsize (`numeric`)\cr font size. |
|||
| 10 |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ #' @param colwidths (`vector` of `numeric`)\cr a vector of column widths. Each element's position in |
|||
| 11 |
- #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths |
|||
| 12 |
- #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' are calculated according to maximum number of characters per column. |
|||
| 13 |
- #' for confidence interval type.+ #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between |
|||
| 14 |
- #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' the first (label) column and the second column of `tbl`. If `colwidths` is specified, |
|||
| 15 |
- #' indicating time unit for data input.+ #' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0. |
|||
| 16 |
- #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years).+ #' |
|||
| 17 |
- #' @param n_events (`integer`)\cr number of events observed.+ #' @return a `ggplot` object. |
|||
| 18 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_incidence_rate")`
+ #' |
|||
| 19 |
- #' to see available statistics for this function.+ #' @examples |
|||
| 20 |
- #'+ #' dta <- data.frame( |
|||
| 21 |
- #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|||
| 22 |
- #'+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
|||
| 23 |
- #' @name incidence_rate+ #' AVAL = c(9:1, rep(NA, 9)) |
|||
| 24 |
- #' @order 1+ #' ) |
|||
| 25 |
- NULL+ #' |
|||
| 26 |
-
+ #' lyt <- basic_table() %>% |
|||
| 27 |
- #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the+ #' split_cols_by(var = "ARM") %>% |
|||
| 28 |
- #' associated confidence interval.+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 29 |
- #'+ #' analyze_vars(vars = "AVAL") |
|||
| 30 |
- #' @return+ #' |
|||
| 31 |
- #' * `s_incidence_rate()` returns the following statistics:+ #' tbl <- build_table(lyt, df = dta) |
|||
| 32 |
- #' - `person_years`: Total person-years at risk.+ #' |
|||
| 33 |
- #' - `n_events`: Total number of events observed.+ #' rtable2gg(tbl) |
|||
| 34 |
- #' - `rate`: Estimated incidence rate.+ #' |
|||
| 35 |
- #' - `rate_ci`: Confidence interval for the incidence rate.+ #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) |
|||
| 37 |
- #' @keywords internal+ #' @export+ |
+ |||
| 38 | ++ |
+ rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
+ |
+ ||
| 39 | +5x | +
+ mat <- rtables::matrix_form(tbl)+ |
+ ||
| 40 | +5x | +
+ mat_strings <- formatters::mf_strings(mat)+ |
+ ||
| 41 | +5x | +
+ mat_aligns <- formatters::mf_aligns(mat)+ |
+ ||
| 42 | +5x | +
+ mat_indent <- formatters::mf_rinfo(mat)$indent+ |
+ ||
| 43 | +5x | +
+ mat_display <- formatters::mf_display(mat)+ |
+ ||
| 44 | +5x | +
+ nlines_hdr <- formatters::mf_nlheader(mat)+ |
+ ||
| 45 | +5x | +
+ shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x))))+ |
+ ||
| 46 | ++ | + + | +||
| 47 | +5x | +
+ tbl_df <- data.frame(mat_strings)+ |
+ ||
| 48 | +5x | +
+ body_rows <- seq(nlines_hdr + 1, nrow(tbl_df))+ |
+ ||
| 49 | +5x | +
+ 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 | +5x | +
+ tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
+ |
+ ||
| 53 | +35x | +
+ ind_i <- mat_indent[i - nlines_hdr] * 4+ |
+ ||
| 54 | +15x | +
+ 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 | +5x | +
+ if (is.null(colwidths)) {
+ |
+ ||
| 59 | +5x | +
+ colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1+ |
+ ||
| 60 | ++ |
+ }+ |
+ ||
| 61 | +5x | +
+ tot_width <- sum(colwidths) + lbl_col_padding+ |
+ ||
| 62 | ++ | + + | +||
| 63 | +5x | +
+ if (length(shared_hdr_rows) > 0) {
+ |
+ ||
| 64 | +4x | +
+ tbl_df <- tbl_df[-shared_hdr_rows, ]+ |
+ ||
| 65 | +4x | +
+ mat_aligns <- mat_aligns[-shared_hdr_rows, ]+ |
+ ||
| 66 | ++ |
+ }+ |
+ ||
| 67 | ++ | + + | +||
| 68 | +5x | +
+ res <- ggplot(data = tbl_df) ++ |
+ ||
| 69 | +5x | +
+ theme_void() ++ |
+ ||
| 70 | +5x | +
+ scale_x_continuous(limits = c(0, tot_width)) ++ |
+ ||
| 71 | +5x | +
+ scale_y_continuous(limits = c(0, nrow(mat_strings))) ++ |
+ ||
| 72 | +5x | +
+ annotate(+ |
+ ||
| 73 | +5x | +
+ "segment",+ |
+ ||
| 74 | +5x | +
+ x = 0, xend = tot_width,+ |
+ ||
| 75 | +5x | +
+ y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5 |
||
| 38 | +76 |
- s_incidence_rate <- function(df,+ ) |
||
| 39 | +77 |
- .var,+ |
||
| 40 | +78 |
- n_events,+ # If header content spans multiple columns, center over these columns |
||
| 41 | -+ | |||
| 79 | +5x |
- is_event,+ if (length(shared_hdr_rows) > 0) {
|
||
| 42 | -+ | |||
| 80 | +4x |
- control = control_incidence_rate()) {
+ mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ]) |
||
| 43 | -1x | +81 | +4x |
- if (!missing(is_event)) {
+ for (hr in shared_hdr_rows) {
|
| 44 | -! | +|||
| 82 | +5x |
- warning("argument is_event will be deprecated. Please use n_events.")
+ hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]] |
||
| 45 | -+ | |||
| 83 | +5x |
-
+ hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr) |
||
| 46 | -! | +|||
| 84 | +5x |
- if (missing(n_events)) {
+ for (idx_hl in seq_len(ncol(hdr_lbls))) {
|
||
| 47 | -! | +|||
| 85 | +11x |
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ cur_lbl <- tail(hdr_lbls[, idx_hl], 1) |
||
| 48 | -! | +|||
| 86 | +11x |
- checkmate::assert_string(.var)+ which_cols <- if (hr == 1) {
|
||
| 49 | -! | +|||
| 87 | +7x |
- checkmate::assert_logical(df[[is_event]], any.missing = FALSE)+ which(mat_strings[hr, ] == hdr_lbls[idx_hl]) |
||
| 50 | -! | +|||
| 88 | +11x |
- checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ } else { # for >2 col splits, only print labels for each unique combo of nested columns
|
||
| 51 | -! | +|||
| 89 | +4x |
- n_events <- is_event+ which( |
||
| 52 | -+ | |||
| 90 | +4x |
- }+ apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl])) |
||
| 53 | +91 |
- } else {
+ ) |
||
| 54 | -1x | +|||
| 92 | +
- assert_df_with_variables(df, list(tte = .var, n_events = n_events))+ } |
|||
| 55 | -1x | +93 | +11x |
- checkmate::assert_string(.var)+ line_pos <- c( |
| 56 | -1x | +94 | +11x |
- checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding, |
| 57 | -1x | +95 | +11x |
- checkmate::assert_integer(df[[n_events]], any.missing = FALSE)+ sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding |
| 58 | +96 |
- }+ ) |
||
| 59 | +97 | |||
| 60 | -1x | -
- input_time_unit <- control$input_time_unit- |
- ||
| 61 | -1x | +98 | +11x |
- num_pt_year <- control$num_pt_year+ res <- res + |
| 62 | -1x | +99 | +11x |
- conf_level <- control$conf_level+ annotate( |
| 63 | -1x | +100 | +11x |
- person_years <- sum(df[[.var]], na.rm = TRUE) * (+ "text", |
| 64 | -1x | +101 | +11x |
- 1 * (input_time_unit == "year") ++ x = mean(line_pos), |
| 65 | -1x | +102 | +11x |
- 1 / 12 * (input_time_unit == "month") ++ y = nrow(mat_strings) + 1 - hr, |
| 66 | -1x | +103 | +11x |
- 1 / 52.14 * (input_time_unit == "week") ++ label = cur_lbl, |
| 67 | -1x | +104 | +11x |
- 1 / 365.24 * (input_time_unit == "day")+ size = fontsize / .pt |
| 68 | +105 |
- )+ ) + |
||
| 69 | -1x | +106 | +11x |
- n_events <- sum(df[[n_events]], na.rm = TRUE)+ annotate( |
| 70 | -+ | |||
| 107 | +11x |
-
+ "segment", |
||
| 71 | -1x | +108 | +11x |
- result <- h_incidence_rate(+ x = line_pos[1], |
| 72 | -1x | +109 | +11x |
- person_years,+ xend = line_pos[2], |
| 73 | -1x | +110 | +11x |
- n_events,+ y = nrow(mat_strings) - hr + 0.5, |
| 74 | -1x | +111 | +11x |
- control+ yend = nrow(mat_strings) - hr + 0.5 |
| 75 | +112 |
- )+ )+ |
+ ||
| 113 | ++ |
+ }+ |
+ ||
| 114 | ++ |
+ }+ |
+ ||
| 115 | ++ |
+ }+ |
+ ||
| 116 | ++ | + + | +||
| 117 | ++ |
+ # Add table columns |
||
| 76 | -1x | +118 | +5x |
- list(+ for (i in seq_len(ncol(tbl_df))) {
|
| 77 | -1x | +119 | +32x |
- person_years = formatters::with_label(person_years, "Total patient-years at risk"),+ res <- res + annotate( |
| 78 | -1x | +120 | +32x |
- n_events = formatters::with_label(n_events, "Number of adverse events observed"),+ "text", |
| 79 | -1x | +121 | +32x |
- rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
+ x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding, |
| 80 | -1x | +122 | +32x |
- rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level))+ y = rev(seq_len(nrow(tbl_df))), |
| 81 | -+ | |||
| 123 | +32x |
- )+ label = tbl_df[, i], |
||
| 82 | -+ | |||
| 124 | +32x |
- }+ hjust = mat_aligns[, i], |
||
| 83 | -+ | |||
| 125 | +32x |
-
+ size = fontsize / .pt |
||
| 84 | +126 |
- #' @describeIn incidence_rate Formatted analysis function which is used as `afun`+ ) |
||
| 85 | +127 |
- #' in `estimate_incidence_rate()`.+ } |
||
| 86 | +128 |
- #'+ + |
+ ||
| 129 | +5x | +
+ res |
||
| 87 | +130 |
- #' @return+ } |
| 88 | +1 |
- #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()].+ #' Count the Number of Patients with a Particular Event |
||
| 89 | +2 |
#' |
||
| 90 | +3 |
- #' @keywords internal+ #' @description `r lifecycle::badge("stable")`
|
||
| 91 | +4 |
- a_incidence_rate <- make_afun(+ #' |
||
| 92 | +5 |
- s_incidence_rate,+ #' The primary analysis variable `.var` denotes the unique patient identifier. |
||
| 93 | +6 |
- .formats = c(+ #' |
||
| 94 | +7 |
- "person_years" = "xx.x",+ #' @inheritParams argument_convention |
||
| 95 | +8 |
- "n_events" = "xx",+ #' @param filters (`character`)\cr a character vector specifying the column names and flag variables |
||
| 96 | +9 |
- "rate" = "xx.xx",+ #' to be used for counting the number of unique identifiers satisfying such conditions. |
||
| 97 | +10 |
- "rate_ci" = "(xx.xx, xx.xx)"+ #' Multiple column names and flags are accepted in this format |
||
| 98 | +11 |
- )+ #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
|
||
| 99 | +12 |
- )+ #' Note that only equality is being accepted as condition. |
||
| 100 | +13 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_event")`
|
||
| 101 | +14 |
- #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments+ #' to see available statistics for this function. |
||
| 102 | +15 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 103 | +16 |
- #'+ #' @seealso [count_patients_with_flags] |
||
| 104 | +17 |
- #' @return+ #' |
||
| 105 | +18 |
- #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions,+ #' @name count_patients_with_event |
||
| 106 | +19 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @order 1 |
||
| 107 | +20 |
- #' the statistics from `s_incidence_rate()` to the table layout.+ NULL |
||
| 108 | +21 |
- #'+ |
||
| 109 | +22 |
- #' @examples+ #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which |
||
| 110 | +23 |
- #' library(dplyr)+ #' the defined event has occurred. |
||
| 111 | +24 |
#' |
||
| 112 | +25 |
- #' df <- data.frame(+ #' @inheritParams analyze_variables |
||
| 113 | +26 |
- #' USUBJID = as.character(seq(6)),+ #' @param .var (`character`)\cr name of the column that contains the unique identifier. |
||
| 114 | +27 |
- #' CNSR = c(0, 1, 1, 0, 0, 0),+ #' |
||
| 115 | +28 |
- #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),+ #' @return |
||
| 116 | +29 |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B"))
+ #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event. |
||
| 117 | +30 |
- #' ) %>%+ #' |
||
| 118 | +31 |
- #' mutate(is_event = CNSR == 0) %>%+ #' @examples |
||
| 119 | +32 |
- #' mutate(n_events = as.integer(is_event))+ #' # `s_count_patients_with_event()` |
||
| 120 | +33 |
#' |
||
| 121 | +34 |
- #' basic_table() %>%+ #' s_count_patients_with_event( |
||
| 122 | +35 |
- #' split_cols_by("ARM") %>%
+ #' tern_ex_adae, |
||
| 123 | +36 |
- #' add_colcounts() %>%+ #' .var = "SUBJID", |
||
| 124 | +37 |
- #' estimate_incidence_rate(+ #' filters = c("TRTEMFL" = "Y")
|
||
| 125 | +38 |
- #' vars = "AVAL",+ #' ) |
||
| 126 | +39 |
- #' n_events = "n_events",+ #' |
||
| 127 | +40 |
- #' control = control_incidence_rate(+ #' s_count_patients_with_event( |
||
| 128 | +41 |
- #' input_time_unit = "month",+ #' tern_ex_adae, |
||
| 129 | +42 |
- #' num_pt_year = 100+ #' .var = "SUBJID", |
||
| 130 | +43 |
- #' )+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
|
||
| 131 | +44 |
- #' ) %>%+ #' ) |
||
| 132 | +45 |
- #' build_table(df)+ #' |
||
| 133 | +46 |
- #'+ #' s_count_patients_with_event( |
||
| 134 | +47 |
- #' @export+ #' tern_ex_adae, |
||
| 135 | +48 |
- #' @order 2+ #' .var = "SUBJID", |
||
| 136 | +49 |
- estimate_incidence_rate <- function(lyt,+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 137 | +50 |
- vars,+ #' denom = "N_col", |
||
| 138 | +51 |
- n_events,+ #' .N_col = 456 |
||
| 139 | +52 |
- control = control_incidence_rate(),+ #' ) |
||
| 140 | +53 |
- na_str = default_na_str(),+ #' |
||
| 141 | +54 |
- nested = TRUE,+ #' @export |
||
| 142 | +55 |
- ...,+ s_count_patients_with_event <- function(df, |
||
| 143 | +56 |
- show_labels = "hidden",+ .var, |
||
| 144 | +57 |
- table_names = vars,+ filters, |
||
| 145 | +58 |
- .stats = NULL,+ .N_col, # nolint |
||
| 146 | +59 |
- .formats = NULL,+ .N_row, # nolint |
||
| 147 | +60 |
- .labels = NULL,+ denom = c("n", "N_row", "N_col")) {
|
||
| 148 | -+ | |||
| 61 | +30x |
- .indent_mods = NULL) {
+ col_names <- names(filters) |
||
| 149 | -1x | +62 | +30x |
- extra_args <- list(n_events = n_events, control = control, ...)+ filter_values <- filters |
| 150 | +63 | |||
| 151 | -1x | +64 | +30x |
- afun <- make_afun(+ checkmate::assert_subset(col_names, colnames(df)) |
| 152 | -1x | +|||
| 65 | +
- a_incidence_rate,+ |
|||
| 153 | -1x | +66 | +30x |
- .stats = .stats,+ temp <- Map( |
| 154 | -1x | +67 | +30x |
- .formats = .formats,+ function(x, y) which(df[[x]] == y), |
| 155 | -1x | +68 | +30x |
- .labels = .labels,+ col_names, |
| 156 | -1x | +69 | +30x |
- .indent_mods = .indent_mods+ filter_values |
| 157 | +70 |
) |
||
| 158 | -- | - - | -||
| 159 | -1x | -
- analyze(- |
- ||
| 160 | -1x | +71 | +30x |
- lyt,+ position_satisfy_filters <- Reduce(intersect, temp) |
| 161 | -1x | +72 | +30x |
- vars,+ id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]])) |
| 162 | -1x | +73 | +30x |
- show_labels = show_labels,+ result <- s_count_values( |
| 163 | -1x | +74 | +30x |
- table_names = table_names,+ as.character(unique(df[[.var]])), |
| 164 | -1x | +75 | +30x |
- afun = afun,+ id_satisfy_filters, |
| 165 | -1x | +76 | +30x |
- na_str = na_str,+ denom = denom, |
| 166 | -1x | +77 | +30x |
- nested = nested,+ .N_col = .N_col, |
| 167 | -1x | +78 | +30x |
- extra_args = extra_args+ .N_row = .N_row |
| 168 | +79 |
) |
||
| 169 | -+ | |||
| 80 | +30x |
- }+ result |
||
| 170 | +81 |
-
+ } |
||
| 171 | +82 |
- #' Helper Functions for Incidence Rate+ |
||
| 172 | +83 |
- #'+ #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun` |
||
| 173 | +84 |
- #' @description `r lifecycle::badge("stable")`
+ #' in `count_patients_with_event()`. |
||
| 174 | +85 |
#' |
||
| 175 | -- |
- #' @param control (`list`)\cr parameters for estimation details, specified by using- |
- ||
| 176 | -- |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:- |
- ||
| 177 | +86 |
- #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.+ #' @return |
||
| 178 | +87 |
- #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 179 | +88 |
- #' for confidence interval type.+ #' |
||
| 180 | +89 |
- #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' @examples |
||
| 181 | +90 |
- #' indicating time unit for data input.+ #' # `a_count_patients_with_event()` |
||
| 182 | +91 |
- #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years).+ #' |
||
| 183 | +92 |
- #' @param person_years (`numeric`)\cr total person-years at risk.+ #' a_count_patients_with_event( |
||
| 184 | +93 |
- #' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval.+ #' tern_ex_adae, |
||
| 185 | +94 |
- #' @param n_events (`integer`)\cr number of events observed.+ #' .var = "SUBJID", |
||
| 186 | +95 |
- #'+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 187 | +96 |
- #' @return Estimated incidence rate `rate` and associated confidence interval `rate_ci`.+ #' .N_col = 100, |
||
| 188 | +97 |
- #'+ #' .N_row = 100 |
||
| 189 | +98 |
- #' @seealso [incidence_rate]+ #' ) |
||
| 190 | +99 |
#' |
||
| 191 | -- |
- #' @name h_incidence_rate- |
- ||
| 192 | +100 |
- NULL+ #' @export |
||
| 193 | +101 |
-
+ a_count_patients_with_event <- make_afun( |
||
| 194 | +102 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ s_count_patients_with_event, |
||
| 195 | +103 |
- #' associated confidence interval based on the normal approximation for the+ .formats = c(count_fraction = format_count_fraction_fixed_dp) |
||
| 196 | +104 |
- #' incidence rate. Unit is one person-year.+ ) |
||
| 197 | +105 |
- #'+ |
||
| 198 | +106 |
- #' @examples+ #' @describeIn count_patients_with_event Layout-creating function which can take statistics function |
||
| 199 | +107 |
- #' h_incidence_rate_normal(200, 2)+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 200 | +108 |
#' |
||
| 201 | -- |
- #' @export- |
- ||
| 202 | -- |
- h_incidence_rate_normal <- function(person_years,- |
- ||
| 203 | -- |
- n_events,- |
- ||
| 204 | -- |
- alpha = 0.05) {
- |
- ||
| 205 | -1x | -
- checkmate::assert_number(person_years)- |
- ||
| 206 | -1x | -
- checkmate::assert_number(n_events)- |
- ||
| 207 | -1x | -
- assert_proportion_value(alpha)- |
- ||
| 208 | +109 | - - | -||
| 209 | -1x | -
- est <- n_events / person_years- |
- ||
| 210 | -1x | -
- se <- sqrt(est / person_years)- |
- ||
| 211 | -1x | -
- ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se+ #' @return |
||
| 212 | +110 | - - | -||
| 213 | -1x | -
- list(rate = est, rate_ci = ci)+ #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions, |
||
| 214 | +111 |
- }+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 215 | +112 |
-
+ #' the statistics from `s_count_patients_with_event()` to the table layout. |
||
| 216 | +113 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' |
||
| 217 | +114 |
- #' associated confidence interval based on the normal approximation for the+ #' @examples |
||
| 218 | +115 |
- #' logarithm of the incidence rate. Unit is one person-year.+ #' # `count_patients_with_event()` |
||
| 219 | +116 |
#' |
||
| 220 | +117 |
- #' @examples+ #' lyt <- basic_table() %>% |
||
| 221 | +118 |
- #' h_incidence_rate_normal_log(200, 2)+ #' split_cols_by("ARM") %>%
|
||
| 222 | +119 |
- #'+ #' add_colcounts() %>% |
||
| 223 | +120 |
- #' @export+ #' count_values( |
||
| 224 | +121 |
- h_incidence_rate_normal_log <- function(person_years,+ #' "STUDYID", |
||
| 225 | +122 |
- n_events,+ #' values = "AB12345", |
||
| 226 | +123 |
- alpha = 0.05) {
- |
- ||
| 227 | -5x | -
- checkmate::assert_number(person_years)- |
- ||
| 228 | -5x | -
- checkmate::assert_number(n_events)- |
- ||
| 229 | -5x | -
- assert_proportion_value(alpha)+ #' .stats = "count", |
||
| 230 | +124 | - - | -||
| 231 | -5x | -
- rate_est <- n_events / person_years- |
- ||
| 232 | -5x | -
- rate_se <- sqrt(rate_est / person_years)- |
- ||
| 233 | -5x | -
- lrate_est <- log(rate_est)+ #' .labels = c(count = "Total AEs") |
||
| 234 | -5x | +|||
| 125 | +
- lrate_se <- rate_se / rate_est+ #' ) %>% |
|||
| 235 | -5x | +|||
| 126 | +
- ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)+ #' count_patients_with_event( |
|||
| 236 | +127 |
-
+ #' "SUBJID", |
||
| 237 | -5x | +|||
| 128 | +
- list(rate = rate_est, rate_ci = ci)+ #' filters = c("TRTEMFL" = "Y"),
|
|||
| 238 | +129 |
- }+ #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"), |
||
| 239 | +130 |
-
+ #' table_names = "tbl_all" |
||
| 240 | +131 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' ) %>% |
||
| 241 | +132 |
- #' associated exact confidence interval. Unit is one person-year.+ #' count_patients_with_event( |
||
| 242 | +133 |
- #'+ #' "SUBJID", |
||
| 243 | +134 |
- #' @examples+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 244 | +135 |
- #' h_incidence_rate_exact(200, 2)+ #' .labels = c(count_fraction = "Total number of patients with fatal AEs"), |
||
| 245 | +136 |
- #'+ #' table_names = "tbl_fatal" |
||
| 246 | +137 |
- #' @export+ #' ) %>% |
||
| 247 | +138 |
- h_incidence_rate_exact <- function(person_years,+ #' count_patients_with_event( |
||
| 248 | +139 |
- n_events,+ #' "SUBJID", |
||
| 249 | +140 |
- alpha = 0.05) {
+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
|
||
| 250 | -1x | +|||
| 141 | +
- checkmate::assert_number(person_years)+ #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"), |
|||
| 251 | -1x | +|||
| 142 | +
- checkmate::assert_number(n_events)+ #' .indent_mods = c(count_fraction = 2L), |
|||
| 252 | -1x | +|||
| 143 | +
- assert_proportion_value(alpha)+ #' table_names = "tbl_rel_fatal" |
|||
| 253 | +144 |
-
+ #' ) |
||
| 254 | -1x | +|||
| 145 | +
- est <- n_events / person_years+ #' |
|||
| 255 | -1x | +|||
| 146 | +
- lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)+ #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) |
|||
| 256 | -1x | +|||
| 147 | +
- ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)+ #' |
|||
| 257 | +148 |
-
+ #' @export |
||
| 258 | -1x | +|||
| 149 | +
- list(rate = est, rate_ci = c(lcl, ucl))+ #' @order 2 |
|||
| 259 | +150 |
- }+ count_patients_with_event <- function(lyt, |
||
| 260 | +151 |
-
+ vars, |
||
| 261 | +152 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ filters, |
||
| 262 | +153 |
- #' associated `Byar`'s confidence interval. Unit is one person-year.+ riskdiff = FALSE, |
||
| 263 | +154 |
- #'+ na_str = default_na_str(), |
||
| 264 | +155 |
- #' @examples+ nested = TRUE, |
||
| 265 | +156 |
- #' h_incidence_rate_byar(200, 2)+ ..., |
||
| 266 | +157 |
- #'+ table_names = vars, |
||
| 267 | +158 |
- #' @export+ .stats = "count_fraction", |
||
| 268 | +159 |
- h_incidence_rate_byar <- function(person_years,+ .formats = NULL, |
||
| 269 | +160 |
- n_events,+ .labels = NULL, |
||
| 270 | +161 |
- alpha = 0.05) {
+ .indent_mods = NULL) {
|
||
| 271 | -1x | +162 | +6x |
- checkmate::assert_number(person_years)+ checkmate::assert_flag(riskdiff) |
| 272 | -1x | +|||
| 163 | +
- checkmate::assert_number(n_events)+ |
|||
| 273 | -1x | +164 | +6x |
- assert_proportion_value(alpha)+ s_args <- list(filters = filters, ...) |
| 274 | +165 | |||
| 275 | -1x | +166 | +6x |
- est <- n_events / person_years+ afun <- make_afun( |
| 276 | -1x | +167 | +6x |
- seg_1 <- n_events + 0.5+ a_count_patients_with_event, |
| 277 | -1x | +168 | +6x |
- seg_2 <- 1 - 1 / (9 * (n_events + 0.5))+ .stats = .stats, |
| 278 | -1x | +169 | +6x |
- seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3+ .formats = .formats, |
| 279 | -1x | +170 | +6x |
- lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years+ .labels = .labels, |
| 280 | -1x | +171 | +6x |
- ucl <- seg_1 * ((seg_2 + seg_3) ^ 3) / person_years # styler: off+ .indent_mods = .indent_mods |
| 281 | +172 | ++ |
+ )+ |
+ |
| 173 | ||||
| 282 | -1x | +174 | +6x |
- list(rate = est, rate_ci = c(lcl, ucl))+ extra_args <- if (isFALSE(riskdiff)) {
|
| 283 | -+ | |||
| 175 | +5x |
- }+ s_args |
||
| 284 | +176 |
-
+ } else {
|
||
| 285 | -+ | |||
| 177 | +1x |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ list( |
||
| 286 | -+ | |||
| 178 | +1x |
- #' associated confidence interval.+ afun = list("s_count_patients_with_event" = afun),
|
||
| 287 | -+ | |||
| 179 | +1x |
- #'+ .stats = .stats, |
||
| 288 | -+ | |||
| 180 | +1x |
- #' @keywords internal+ .indent_mods = .indent_mods, |
||
| 289 | -+ | |||
| 181 | +1x |
- h_incidence_rate <- function(person_years,+ s_args = s_args |
||
| 290 | +182 |
- n_events,+ ) |
||
| 291 | +183 |
- control = control_incidence_rate()) {
+ } |
||
| 292 | -4x | +|||
| 184 | +
- alpha <- 1 - control$conf_level+ |
|||
| 293 | -4x | +185 | +6x |
- est <- switch(control$conf_type,+ analyze( |
| 294 | -4x | +186 | +6x |
- normal = h_incidence_rate_normal(person_years, n_events, alpha),+ lyt, |
| 295 | -4x | +187 | +6x |
- normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),+ vars, |
| 296 | -4x | +188 | +6x |
- exact = h_incidence_rate_exact(person_years, n_events, alpha),+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 297 | -4x | -
- byar = h_incidence_rate_byar(person_years, n_events, alpha)- |
- ||
| 298 | -- |
- )- |
- ||
| 299 | -+ | 189 | +6x |
-
+ na_str = na_str, |
| 300 | -4x | +190 | +6x |
- num_pt_year <- control$num_pt_year+ nested = nested, |
| 301 | -4x | +191 | +6x |
- list(+ extra_args = extra_args, |
| 302 | -4x | +192 | +6x |
- rate = est$rate * num_pt_year,+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 303 | -4x | +193 | +6x |
- rate_ci = est$rate_ci * num_pt_year+ table_names = table_names |
| 304 | +194 |
) |
||
| 305 | +195 |
}@@ -126872,14 +129141,14 @@ tern coverage - 90.46% |
| 1 |
- #' Add Titles, Footnotes, Page Number, and a Bounding Box to a Grid Grob+ #' Tabulate Biomarker Effects on Survival by Subgroup |
|||
| 5 |
- #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots)+ #' Tabulate the estimated effects of multiple continuous biomarker variables |
|||
| 6 |
- #' with title, footnote, and page numbers.+ #' across population subgroups. |
|||
| 8 |
- #' @inheritParams grid::grob+ #' @inheritParams fit_coxreg_multivar |
|||
| 9 |
- #' @param grob a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown.+ #' @inheritParams survival_duration_subgroups |
|||
| 10 |
- #' @param titles vector of character strings. Vector elements are separated by a newline and strings are wrapped+ #' @inheritParams argument_convention |
|||
| 11 |
- #' according to the page width.+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
|||
| 12 |
- #' @param footnotes vector of character string. Same rules as for `titles`.+ #' [extract_survival_biomarkers()]. |
|||
| 13 |
- #' @param page string with page numeration, if `NULL` then no page number is displayed.+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
|||
| 14 |
- #' @param width_titles unit object+ #' * `n_tot_events`: Total number of events per group. |
|||
| 15 |
- #' @param width_footnotes unit object+ #' * `n_tot`: Total number of observations per group. |
|||
| 16 |
- #' @param border boolean, whether a a border should be drawn around the plot or not.+ #' * `median`: Median survival time. |
|||
| 17 |
- #' @param margins unit object of length 4+ #' * `hr`: Hazard ratio. |
|||
| 18 |
- #' @param padding unit object of length 4+ #' * `ci`: Confidence interval of hazard ratio. |
|||
| 19 |
- #' @param outer_margins unit object of length 4+ #' * `pval`: p-value of the effect. |
|||
| 20 |
- #' @param gp_titles a `gpar` object+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required. |
|||
| 21 |
- #' @param gp_footnotes a `gpar` object+ #' |
|||
| 22 |
- #'+ #' @details These functions create a layout starting from a data frame which contains |
|||
| 23 |
- #' @return A grid grob (`gTree`).+ #' the required statistics. The tables are then typically used as input for forest plots. |
|||
| 25 |
- #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually.+ #' @examples |
|||
| 26 |
- #'+ #' library(dplyr) |
|||
| 27 |
- #' @examples+ #' |
|||
| 28 |
- #' library(grid)+ #' adtte <- tern_ex_adtte |
|||
| 30 |
- #' titles <- c(+ #' # Save variable labels before data processing steps. |
|||
| 31 |
- #' "Edgar Anderson's Iris Data",+ #' adtte_labels <- formatters::var_labels(adtte) |
|||
| 32 |
- #' paste(+ #' |
|||
| 33 |
- #' "This famous (Fisher's or Anderson's) iris data set gives the measurements",+ #' adtte_f <- adtte %>% |
|||
| 34 |
- #' "in centimeters of the variables sepal length and width and petal length",+ #' filter(PARAMCD == "OS") %>% |
|||
| 35 |
- #' "and width, respectively, for 50 flowers from each of 3 species of iris."+ #' mutate( |
|||
| 36 |
- #' )+ #' AVALU = as.character(AVALU), |
|||
| 37 |
- #' )+ #' is_event = CNSR == 0 |
|||
| 38 |
- #'+ #' ) |
|||
| 39 |
- #' footnotes <- c(+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
|||
| 40 |
- #' "The species are Iris setosa, versicolor, and virginica.",+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|||
| 41 |
- #' paste(+ #' |
|||
| 42 |
- #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
|||
| 43 |
- #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."+ #' # in multiple regression models containing one covariate `RACE`, |
|||
| 44 |
- #' )+ #' # as well as one stratification variable `STRATA1`. The subgroups |
|||
| 45 |
- #' )+ #' # are defined by the levels of `BMRKR2`. |
|||
| 47 |
- #' ## empty plot+ #' df <- extract_survival_biomarkers( |
|||
| 48 |
- #' grid.newpage()+ #' variables = list( |
|||
| 49 |
- #'+ #' tte = "AVAL", |
|||
| 50 |
- #' grid.draw(+ #' is_event = "is_event", |
|||
| 51 |
- #' decorate_grob(+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 52 |
- #' NULL,+ #' strata = "STRATA1", |
|||
| 53 |
- #' titles = titles,+ #' covariates = "SEX", |
|||
| 54 |
- #' footnotes = footnotes,+ #' subgroups = "BMRKR2" |
|||
| 55 |
- #' page = "Page 4 of 10"+ #' ), |
|||
| 56 |
- #' )+ #' data = adtte_f |
|||
| 58 |
- #'+ #' df |
|||
| 59 |
- #' # grid+ #' |
|||
| 60 |
- #' p <- gTree(+ #' # Here we group the levels of `BMRKR2` manually. |
|||
| 61 |
- #' children = gList(+ #' df_grouped <- extract_survival_biomarkers( |
|||
| 62 |
- #' rectGrob(),+ #' variables = list( |
|||
| 63 |
- #' xaxisGrob(),+ #' tte = "AVAL", |
|||
| 64 |
- #' yaxisGrob(),+ #' is_event = "is_event", |
|||
| 65 |
- #' textGrob("Sepal.Length", y = unit(-4, "lines")),
+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 66 |
- #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
+ #' strata = "STRATA1", |
|||
| 67 |
- #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)+ #' covariates = "SEX", |
|||
| 68 |
- #' ),+ #' subgroups = "BMRKR2" |
|||
| 69 |
- #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))+ #' ), |
|||
| 70 |
- #' )+ #' data = adtte_f, |
|||
| 71 |
- #' grid.newpage()+ #' groups_lists = list( |
|||
| 72 |
- #' grid.draw(p)+ #' BMRKR2 = list( |
|||
| 73 |
- #'+ #' "low" = "LOW", |
|||
| 74 |
- #' grid.newpage()+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 75 |
- #' grid.draw(+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|||
| 76 |
- #' decorate_grob(+ #' ) |
|||
| 77 |
- #' grob = p,+ #' ) |
|||
| 78 |
- #' titles = titles,+ #' ) |
|||
| 79 |
- #' footnotes = footnotes,+ #' df_grouped |
|||
| 80 |
- #' page = "Page 6 of 129"+ #' |
|||
| 81 |
- #' )+ #' @name survival_biomarkers_subgroups |
|||
| 82 |
- #' )+ #' @order 1 |
|||
| 83 |
- #'+ NULL |
|||
| 84 |
- #' ## with ggplot2+ |
|||
| 85 |
- #' library(ggplot2)+ #' Prepares Survival Data Estimates for Multiple Biomarkers in a Single Data Frame |
|||
| 87 |
- #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) ++ #' @description `r lifecycle::badge("stable")`
|
|||
| 88 |
- #' ggplot2::geom_point()+ #' |
|||
| 89 |
- #' p_gg+ #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates, |
|||
| 90 |
- #' p <- ggplotGrob(p_gg)+ #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame. |
|||
| 91 |
- #' grid.newpage()+ #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements |
|||
| 92 |
- #' grid.draw(+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strata`. |
|||
| 93 |
- #' decorate_grob(+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|||
| 94 |
- #' grob = p,+ #' |
|||
| 95 |
- #' titles = titles,+ #' @inheritParams argument_convention |
|||
| 96 |
- #' footnotes = footnotes,+ #' @inheritParams fit_coxreg_multivar |
|||
| 97 |
- #' page = "Page 6 of 129"+ #' @inheritParams survival_duration_subgroups |
|||
| 98 |
- #' )+ #' |
|||
| 99 |
- #' )+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`, |
|||
| 100 |
- #'+ #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
|||
| 101 |
- #' ## with lattice+ #' `var_label`, and `row_type`. |
|||
| 102 |
- #' library(lattice)+ #' |
|||
| 103 |
- #'+ #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()]. |
|||
| 104 | - |
- #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)- |
- ||
| 105 | -- |
- #' p <- grid.grab()- |
- ||
| 106 | -- |
- #' grid.newpage()- |
- ||
| 107 | -- |
- #' grid.draw(- |
- ||
| 108 | -- |
- #' decorate_grob(- |
- ||
| 109 | -- |
- #' grob = p,- |
- ||
| 110 | -- |
- #' titles = titles,- |
- ||
| 111 | -- |
- #' footnotes = footnotes,- |
- ||
| 112 | -- |
- #' page = "Page 6 of 129"- |
- ||
| 113 | -- |
- #' )- |
- ||
| 114 | -- |
- #' )- |
- ||
| 115 | -- |
- #'- |
- ||
| 116 | -- |
- #' # with gridExtra - no borders- |
- ||
| 117 | -- |
- #' library(gridExtra)- |
- ||
| 118 | -- |
- #' grid.newpage()- |
- ||
| 119 | -- |
- #' grid.draw(- |
- ||
| 120 | -- |
- #' decorate_grob(- |
- ||
| 121 | -- |
- #' tableGrob(- |
- ||
| 122 | -- |
- #' head(mtcars)- |
- ||
| 123 | -- |
- #' ),- |
- ||
| 124 | -- |
- #' titles = "title",- |
- ||
| 125 | -- |
- #' footnotes = "footnote",- |
- ||
| 126 | -- |
- #' border = FALSE- |
- ||
| 127 | -- |
- #' )- |
- ||
| 128 | -- |
- #' )- |
- ||
| 129 | -
#' |
|||
| 130 | +105 |
#' @export |
- ||
| 131 | -- |
- decorate_grob <- function(grob,- |
- ||
| 132 | -- |
- titles,- |
- ||
| 133 | -- |
- footnotes,- |
- ||
| 134 | -- |
- page = "",- |
- ||
| 135 | -- |
- width_titles = grid::unit(1, "npc") - grid::unit(1.5, "cm"),- |
- ||
| 136 | -- |
- width_footnotes = grid::unit(1, "npc") - grid::unit(1.5, "cm"),- |
- ||
| 137 | -- |
- border = TRUE,- |
- ||
| 138 | -- |
- margins = grid::unit(c(1, 0, 1, 0), "lines"),- |
- ||
| 139 | -- |
- padding = grid::unit(rep(1, 4), "lines"),- |
- ||
| 140 | -- |
- outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),- |
- ||
| 141 | -- |
- gp_titles = grid::gpar(),- |
- ||
| 142 | -- |
- gp_footnotes = grid::gpar(fontsize = 8),- |
- ||
| 143 | -- |
- name = NULL,- |
- ||
| 144 | -- |
- gp = grid::gpar(),- |
- ||
| 145 | -- |
- vp = NULL) {
- |
- ||
| 146 | -9x | -
- st_titles <- split_text_grob(- |
- ||
| 147 | -9x | -
- titles,- |
- ||
| 148 | -9x | -
- x = 0, y = 1,- |
- ||
| 149 | -9x | -
- just = c("left", "top"),
- |
- ||
| 150 | -9x | -
- width = width_titles,- |
- ||
| 151 | -9x | -
- vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),- |
- ||
| 152 | -9x | -
- gp = gp_titles- |
- ||
| 153 | -- |
- )- |
- ||
| 154 | -- | - - | -||
| 155 | -9x | -
- st_footnotes <- split_text_grob(- |
- ||
| 156 | -9x | -
- footnotes,- |
- ||
| 157 | -9x | -
- x = 0, y = 1,- |
- ||
| 158 | -9x | -
- just = c("left", "top"),
- |
- ||
| 159 | -9x | -
- width = width_footnotes,- |
- ||
| 160 | -9x | -
- vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),- |
- ||
| 161 | -9x | -
- gp = gp_footnotes- |
- ||
| 162 | -- |
- )- |
- ||
| 163 | -- | - - | -||
| 164 | -9x | -
- pg_footnote <- grid::textGrob(- |
- ||
| 165 | -9x | -
- paste("\n", page),
- |
- ||
| 166 | -9x | -
- x = 1, y = 0,- |
- ||
| 167 | -9x | +|||
| 106 | +
- just = c("right", "bottom"),
+ extract_survival_biomarkers <- function(variables, |
|||
| 168 | -9x | +|||
| 107 | +
- vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1),+ data, |
|||
| 169 | -9x | +|||
| 108 | +
- gp = gp_footnotes+ groups_lists = list(), |
|||
| 170 | +109 |
- )+ control = control_coxreg(), |
||
| 171 | +110 |
-
+ label_all = "All Patients") {
|
||
| 172 | -9x | +111 | +5x |
- grid::gTree(+ if ("strat" %in% names(variables)) {
|
| 173 | -9x | +|||
| 112 | +! |
- grob = grob,+ warning( |
||
| 174 | -9x | +|||
| 113 | +! |
- titles = titles,+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_biomarkers() ", |
||
| 175 | -9x | +|||
| 114 | +! |
- footnotes = footnotes,+ "was deprecated in tern 0.9.3.\n ", |
||
| 176 | -9x | +|||
| 115 | +! |
- page = page,+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 177 | -9x | +|||
| 116 | +
- width_titles = width_titles,+ ) |
|||
| 178 | -9x | +|||
| 117 | +! |
- width_footnotes = width_footnotes,+ variables[["strata"]] <- variables[["strat"]] |
||
| 179 | -9x | +|||
| 118 | +
- border = border,+ } |
|||
| 180 | -9x | +|||
| 119 | +
- margins = margins,+ |
|||
| 181 | -9x | +120 | +5x |
- padding = padding,+ checkmate::assert_list(variables) |
| 182 | -9x | +121 | +5x |
- outer_margins = outer_margins,+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 183 | -9x | +122 | +5x |
- gp_titles = gp_titles,+ checkmate::assert_string(label_all) |
| 184 | -9x | +|||
| 123 | +
- gp_footnotes = gp_footnotes,+ |
|||
| 185 | -9x | +|||
| 124 | +
- children = grid::gList(+ # Start with all patients. |
|||
| 186 | -9x | +125 | +5x |
- grid::gTree(+ result_all <- h_coxreg_mult_cont_df( |
| 187 | -9x | +126 | +5x |
- children = grid::gList(+ variables = variables, |
| 188 | -9x | +127 | +5x |
- st_titles,+ data = data, |
| 189 | -9x | +128 | +5x |
- grid::gTree(+ control = control+ |
+
| 129 | ++ |
+ ) |
||
| 190 | -9x | +130 | +5x |
- children = grid::gList(+ result_all$subgroup <- label_all |
| 191 | -9x | +131 | +5x |
- if (border) grid::rectGrob(),+ result_all$var <- "ALL" |
| 192 | -9x | +132 | +5x |
- grid::gTree(+ result_all$var_label <- label_all |
| 193 | -9x | +133 | +5x |
- children = grid::gList(+ result_all$row_type <- "content" |
| 194 | -9x | +134 | +5x |
- grob+ if (is.null(variables$subgroups)) {
|
| 195 | +135 |
- ),+ # Only return result for all patients. |
||
| 196 | -9x | +136 | +1x |
- vp = grid::plotViewport(margins = padding)+ result_all |
| 197 | +137 |
- )+ } else {
|
||
| 198 | +138 |
- ),+ # Add subgroups results. |
||
| 199 | -9x | +139 | +4x |
- vp = grid::vpStack(+ l_data <- h_split_by_subgroups( |
| 200 | -9x | +140 | +4x |
- grid::viewport(layout.pos.row = 2, layout.pos.col = 1),+ data, |
| 201 | -9x | +141 | +4x |
- grid::plotViewport(margins = margins)+ variables$subgroups, |
| 202 | -+ | |||
| 142 | +4x |
- )+ groups_lists = groups_lists |
||
| 203 | +143 |
- ),+ ) |
||
| 204 | -9x | +144 | +4x |
- st_footnotes,+ l_result <- lapply(l_data, function(grp) {
|
| 205 | -9x | -
- pg_footnote- |
- ||
| 206 | -+ | 145 | +20x |
- ),+ result <- h_coxreg_mult_cont_df( |
| 207 | -9x | +146 | +20x |
- childrenvp = NULL,+ variables = variables, |
| 208 | -9x | +147 | +20x |
- name = "titles_grob_footnotes",+ data = grp$df, |
| 209 | -9x | +148 | +20x |
- vp = grid::vpStack(+ control = control |
| 210 | -9x | +|||
| 149 | +
- grid::plotViewport(margins = outer_margins),+ ) |
|||
| 211 | -9x | +150 | +20x |
- grid::viewport(+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 212 | -9x | +151 | +20x |
- layout = grid::grid.layout(+ cbind(result, result_labels) |
| 213 | -9x | +|||
| 152 | +
- nrow = 4, ncol = 1,+ }) |
|||
| 214 | -9x | +153 | +4x |
- heights = grid::unit.c(+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 215 | -9x | +154 | +4x |
- grid::grobHeight(st_titles),+ result_subgroups$row_type <- "analysis" |
| 216 | -9x | +155 | +4x |
- grid::unit(1, "null"),+ rbind( |
| 217 | -9x | +156 | +4x |
- grid::grobHeight(st_footnotes),+ result_all, |
| 218 | -9x | +157 | +4x |
- grid::grobHeight(pg_footnote)+ result_subgroups |
| 219 | +158 |
- )+ ) |
||
| 220 | +159 |
- )+ } |
||
| 221 | +160 |
- )+ } |
||
| 222 | +161 |
- )+ |
||
| 223 | +162 |
- )+ #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table |
||
| 224 | +163 |
- ),- |
- ||
| 225 | -9x | -
- name = name,- |
- ||
| 226 | -9x | -
- gp = gp,- |
- ||
| 227 | -9x | -
- vp = vp,- |
- ||
| 228 | -9x | -
- cl = "decoratedGrob"+ #' summarizing biomarker effects on survival by subgroup. |
||
| 229 | +164 |
- )+ #' |
||
| 230 | +165 |
- }+ #' @return An `rtables` table summarizing biomarker effects on survival by subgroup. |
||
| 231 | +166 |
-
+ #' |
||
| 232 | +167 |
- #' @importFrom grid validDetails+ #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does |
||
| 233 | +168 |
- #' @noRd+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 234 | +169 |
- validDetails.decoratedGrob <- function(x) {
- |
- ||
| 235 | -! | -
- checkmate::assert_character(x$titles)- |
- ||
| 236 | -! | -
- checkmate::assert_character(x$footnotes)+ #' created by combining multiple subtables. |
||
| 237 | +170 | - - | -||
| 238 | -! | -
- if (!is.null(x$grob)) {
- |
- ||
| 239 | -! | -
- checkmate::assert_true(grid::is.grob(x$grob))+ #' |
||
| 240 | +171 |
- }- |
- ||
| 241 | -! | -
- if (length(x$page) == 1) {
- |
- ||
| 242 | -! | -
- checkmate::assert_character(x$page)+ #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()]. |
||
| 243 | +172 |
- }- |
- ||
| 244 | -! | -
- if (!grid::is.unit(x$outer_margins)) {
- |
- ||
| 245 | -! | -
- checkmate::assert_vector(x$outer_margins, len = 4)+ #' |
||
| 246 | +173 |
- }+ #' @examples |
||
| 247 | -! | +|||
| 174 | +
- if (!grid::is.unit(x$margins)) {
+ #' ## Table with default columns. |
|||
| 248 | -! | +|||
| 175 | +
- checkmate::assert_vector(x$margins, len = 4)+ #' tabulate_survival_biomarkers(df) |
|||
| 249 | +176 |
- }+ #' |
||
| 250 | -! | +|||
| 177 | +
- if (!grid::is.unit(x$padding)) {
+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
|||
| 251 | -! | +|||
| 178 | +
- checkmate::assert_vector(x$padding, len = 4)+ #' tab <- tabulate_survival_biomarkers( |
|||
| 252 | +179 |
- }+ #' df = df, |
||
| 253 | +180 |
-
+ #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
|
||
| 254 | -! | +|||
| 181 | +
- x+ #' time_unit = as.character(adtte_f$AVALU[1]) |
|||
| 255 | +182 |
- }+ #' ) |
||
| 256 | +183 |
-
+ #' |
||
| 257 | +184 |
- #' @importFrom grid widthDetails+ #' ## Finally produce the forest plot. |
||
| 258 | +185 |
- #' @noRd+ #' \donttest{
|
||
| 259 | +186 |
- widthDetails.decoratedGrob <- function(x) {
+ #' g_forest(tab, xlim = c(0.8, 1.2)) |
||
| 260 | -! | +|||
| 187 | +
- grid::unit(1, "null")+ #' } |
|||
| 261 | +188 |
- }+ #' |
||
| 262 | +189 |
-
+ #' @export |
||
| 263 | +190 |
- #' @importFrom grid heightDetails+ #' @order 2 |
||
| 264 | +191 |
- #' @noRd+ tabulate_survival_biomarkers <- function(df, |
||
| 265 | +192 |
- heightDetails.decoratedGrob <- function(x) {
+ vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 266 | -! | +|||
| 193 | +
- grid::unit(1, "null")+ groups_lists = list(), |
|||
| 267 | +194 |
- }+ control = control_coxreg(), |
||
| 268 | +195 |
-
+ label_all = "All Patients", |
||
| 269 | +196 |
- # Adapted from Paul Murell R Graphics 2nd Edition+ time_unit = NULL, |
||
| 270 | +197 |
- # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R+ na_str = default_na_str(), |
||
| 271 | +198 |
- split_string <- function(text, width) {
+ .indent_mods = 0L) {
|
||
| 272 | -19x | +199 | +4x |
- strings <- strsplit(text, " ")+ checkmate::assert_data_frame(df) |
| 273 | -19x | +200 | +4x |
- out_string <- NA+ checkmate::assert_character(df$biomarker) |
| 274 | -19x | +201 | +4x |
- for (string_i in seq_along(strings)) {
+ checkmate::assert_character(df$biomarker_label) |
| 275 | -19x | +202 | +4x |
- newline_str <- strings[[string_i]]+ checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
|
| 276 | -6x | +|||
| 203 | +
- if (length(newline_str) == 0) newline_str <- ""+ |
|||
| 277 | -19x | +204 | +4x |
- if (is.na(out_string[string_i])) {
+ extra_args <- list(groups_lists = groups_lists, control = control, label_all = label_all) |
| 278 | -19x | +|||
| 205 | +
- out_string[string_i] <- newline_str[[1]][[1]]+ |
|||
| 279 | -19x | +206 | +4x |
- linewidth <- grid::stringWidth(out_string[string_i])+ df_subs <- split(df, f = df$biomarker) |
| 280 | -+ | |||
| 207 | +4x |
- }+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
||
| 281 | -19x | +208 | +7x |
- gapwidth <- grid::stringWidth(" ")
+ tab_sub <- h_tab_surv_one_biomarker( |
| 282 | -19x | +209 | +7x |
- availwidth <- as.numeric(width)+ df = df_sub, |
| 283 | -19x | +210 | +7x |
- if (length(newline_str) > 1) {
+ vars = vars, |
| 284 | +211 | 7x |
- for (i in seq(2, length(newline_str))) {
+ time_unit = time_unit, |
|
| 285 | -83x | +212 | +7x |
- width_i <- grid::stringWidth(newline_str[i])+ na_str = na_str, |
| 286 | -83x | +213 | +7x |
- if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ .indent_mods = .indent_mods, |
| 287 | -78x | +214 | +7x |
- sep <- " "+ extra_args = extra_args |
| 288 | -78x | +|||
| 215 | +
- linewidth <- linewidth + gapwidth + width_i+ ) |
|||
| 289 | +216 |
- } else {
+ # Insert label row as first row in table. |
||
| 290 | -5x | +217 | +7x |
- sep <- "\n"+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
| 291 | -5x | +218 | +7x |
- linewidth <- width_i+ tab_sub |
| 292 | +219 |
- }+ }) |
||
| 293 | -83x | +220 | +4x |
- out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep)+ result <- do.call(rbind, tabs) |
| 294 | +221 |
- }+ |
||
| 295 | -+ | |||
| 222 | +4x |
- }+ n_tot_ids <- grep("^n_tot", vars)
|
||
| 296 | -+ | |||
| 223 | +4x |
- }+ hr_id <- match("hr", vars)
|
||
| 297 | -19x | +224 | +4x |
- paste(out_string, collapse = "\n")+ ci_id <- match("ci", vars)
|
| 298 | -+ | |||
| 225 | +4x |
- }+ structure( |
||
| 299 | -+ | |||
| 226 | +4x |
-
+ result, |
||
| 300 | -+ | |||
| 227 | +4x |
- #' Split Text According To Available Text Width+ forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
|
||
| 301 | -+ | |||
| 228 | +4x |
- #'+ col_x = hr_id, |
||
| 302 | -+ | |||
| 229 | +4x |
- #' Dynamically wrap text.+ col_ci = ci_id, |
||
| 303 | -+ | |||
| 230 | +4x |
- #'+ col_symbol_size = n_tot_ids[1] |
||
| 304 | +231 |
- #' @inheritParams grid::grid.text+ ) |
||
| 305 | +232 |
- #' @param text character string+ } |
| 306 | +1 |
- #' @param width a unit object specifying max width of text+ #' `rtables` Access Helper Functions |
||
| 307 | +2 |
#' |
||
| 308 | +3 |
- #' @return A text grob.+ #' @description `r lifecycle::badge("stable")`
|
||
| 309 | +4 |
#' |
||
| 310 | +5 |
- #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition`+ #' These are a couple of functions that help with accessing the data in `rtables` objects. |
||
| 311 | +6 |
- #'+ #' Currently these work for occurrence tables, which are defined as having a count as the first |
||
| 312 | +7 |
- #' @keywords internal+ #' element and a fraction as the second element in each cell. |
||
| 313 | +8 |
- split_text_grob <- function(text,+ #' |
||
| 314 | +9 |
- x = grid::unit(0.5, "npc"),+ #' @seealso [prune_occurrences] for usage of these functions. |
||
| 315 | +10 |
- y = grid::unit(0.5, "npc"),+ #' |
||
| 316 | +11 |
- width = grid::unit(1, "npc"),+ #' @name rtables_access |
||
| 317 | +12 |
- just = "centre",+ NULL |
||
| 318 | +13 |
- hjust = NULL,+ |
||
| 319 | +14 |
- vjust = NULL,+ #' @describeIn rtables_access Helper function to extract the first values from each content |
||
| 320 | +15 |
- default.units = "npc", # nolint+ #' cell and from specified columns in a `TableRow`. Defaults to all columns. |
||
| 321 | +16 |
- name = NULL,+ #' |
||
| 322 | +17 |
- gp = grid::gpar(),+ #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table. |
||
| 323 | +18 |
- vp = NULL) {
- |
- ||
| 324 | -18x | -
- if (!grid::is.unit(x)) x <- grid::unit(x, default.units)- |
- ||
| 325 | -18x | -
- if (!grid::is.unit(y)) y <- grid::unit(y, default.units)- |
- ||
| 326 | -! | -
- if (!grid::is.unit(width)) width <- grid::unit(width, default.units)- |
- ||
| 327 | -! | -
- if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
- |
- ||
| 328 | -! | -
- if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
- |
- ||
| 329 | -18x | -
- if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
+ #' @param col_names (`character`)\cr the names of the columns to extract from. |
||
| 330 | +19 | - - | -||
| 331 | -18x | -
- if (length(gp) > 0) { # account for effect of gp on text width
- |
- ||
| 332 | -9x | -
- width <- width * grid::convertWidth(grid::grobWidth(grid::textGrob(text)), "npc", valueOnly = TRUE) /- |
- ||
| 333 | -9x | -
- grid::convertWidth(grid::grobWidth(grid::textGrob(text, gp = gp)), "npc", valueOnly = TRUE)+ #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided, |
||
| 334 | +20 |
- }+ #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single |
||
| 335 | +21 |
-
+ #' column split. |
||
| 336 | +22 |
- ## if it is a fixed unit then we do not need to recalculate when viewport resized+ #' |
||
| 337 | -18x | +|||
| 23 | +
- if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) &&+ #' @return |
|||
| 338 | -18x | +|||
| 24 | +
- attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
+ #' * `h_row_first_values()` returns a `vector` of numeric values. |
|||
| 339 | -! | +|||
| 25 | +
- attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")+ #' |
|||
| 340 | +26 |
- }+ #' @examples |
||
| 341 | +27 |
-
+ #' tbl <- basic_table() %>% |
||
| 342 | -18x | +|||
| 28 | +
- grid::grid.text(+ #' split_cols_by("ARM") %>%
|
|||
| 343 | -18x | +|||
| 29 | +
- label = split_string(text, width),+ #' split_rows_by("RACE") %>%
|
|||
| 344 | -18x | +|||
| 30 | +
- x = x, y = y,+ #' analyze("AGE", function(x) {
|
|||
| 345 | -18x | +|||
| 31 | +
- just = just,+ #' list( |
|||
| 346 | -18x | +|||
| 32 | +
- hjust = hjust,+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"), |
|||
| 347 | -18x | +|||
| 33 | +
- vjust = vjust,+ #' "n" = length(x), |
|||
| 348 | -18x | +|||
| 34 | +
- rot = 0,+ #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)") |
|||
| 349 | -18x | +|||
| 35 | +
- check.overlap = FALSE,+ #' ) |
|||
| 350 | -18x | +|||
| 36 | +
- name = name,+ #' }) %>% |
|||
| 351 | -18x | +|||
| 37 | +
- gp = gp,+ #' build_table(tern_ex_adsl) %>% |
|||
| 352 | -18x | +|||
| 38 | +
- vp = vp,+ #' prune_table() |
|||
| 353 | -18x | +|||
| 39 | +
- draw = FALSE+ #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]] |
|||
| 354 | +40 |
- )+ #' result <- max(h_row_first_values(tree_row_elem)) |
||
| 355 | +41 |
- }+ #' result |
||
| 356 | +42 |
-
+ #' |
||
| 357 | +43 |
- #' @importFrom grid validDetails+ #' @export |
||
| 358 | +44 |
- #' @noRd+ h_row_first_values <- function(table_row, |
||
| 359 | +45 |
- validDetails.dynamicSplitText <- function(x) {
+ col_names = NULL, |
||
| 360 | -! | +|||
| 46 | +
- checkmate::assert_character(x$text)+ col_indices = NULL) {
|
|||
| 361 | -! | +|||
| 47 | +727x |
- checkmate::assert_true(grid::is.unit(x$width))+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
||
| 362 | -! | +|||
| 48 | +727x |
- checkmate::assert_vector(x$width, len = 1)+ checkmate::assert_integerish(col_indices) |
||
| 363 | -! | +|||
| 49 | +727x |
- x+ checkmate::assert_subset(col_indices, seq_len(ncol(table_row))) |
||
| 364 | +50 |
- }+ |
||
| 365 | +51 |
-
+ # Main values are extracted |
||
| 366 | -+ | |||
| 52 | +727x |
- #' @importFrom grid heightDetails+ row_vals <- row_values(table_row)[col_indices] |
||
| 367 | +53 |
- #' @noRd+ |
||
| 368 | +54 |
- heightDetails.dynamicSplitText <- function(x) {
+ # Main return |
||
| 369 | -! | +|||
| 55 | +727x |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ vapply(row_vals, function(rv) {
|
||
| 370 | -! | +|||
| 56 | +2066x |
- attr(x$text, "fixed_text")+ if (is.null(rv)) {
+ |
+ ||
| 57 | +727x | +
+ NA_real_ |
||
| 371 | +58 |
- } else {
+ } else {
|
||
| 372 | -! | +|||
| 59 | +2063x |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ rv[1L] |
||
| 373 | +60 |
- }+ } |
||
| 374 | -! | +|||
| 61 | +727x |
- grid::stringHeight(txt)+ }, FUN.VALUE = numeric(1)) |
||
| 375 | +62 |
} |
||
| 376 | +63 | |||
| 377 | +64 |
- #' @importFrom grid widthDetails+ #' @describeIn rtables_access Helper function that extracts row values and checks if they are |
||
| 378 | +65 |
- #' @noRd+ #' convertible to integers (`integerish` values). |
||
| 379 | +66 |
- widthDetails.dynamicSplitText <- function(x) {
+ #' |
||
| 380 | -! | +|||
| 67 | +
- x$width+ #' @return |
|||
| 381 | +68 |
- }+ #' * `h_row_counts()` returns a `vector` of numeric values. |
||
| 382 | +69 |
-
+ #' |
||
| 383 | +70 |
- #' @importFrom grid drawDetails+ #' @examples |
||
| 384 | +71 |
- #' @noRd+ #' # Row counts (integer values) |
||
| 385 | +72 |
- drawDetails.dynamicSplitText <- function(x, recording) {
+ #' # h_row_counts(tree_row_elem) # Fails because there are no integers |
||
| 386 | -! | +|||
| 73 | +
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ #' # Using values with integers |
|||
| 387 | -! | +|||
| 74 | +
- attr(x$text, "fixed_text")+ #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]] |
|||
| 388 | +75 |
- } else {
+ #' result <- h_row_counts(tree_row_elem) |
||
| 389 | -! | +|||
| 76 | +
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ #' # result |
|||
| 390 | +77 |
- }+ #' |
||
| 391 | +78 |
-
+ #' @export |
||
| 392 | -! | +|||
| 79 | +
- x$width <- NULL+ h_row_counts <- function(table_row, |
|||
| 393 | -! | +|||
| 80 | +
- x$label <- txt+ col_names = NULL, |
|||
| 394 | -! | +|||
| 81 | +
- x$text <- NULL+ col_indices = NULL) {
|
|||
| 395 | -! | +|||
| 82 | +727x |
- class(x) <- c("text", class(x)[-1])
+ counts <- h_row_first_values(table_row, col_names, col_indices) |
||
| 396 | -+ | |||
| 83 | +727x |
-
+ checkmate::assert_integerish(counts) |
||
| 397 | -! | +|||
| 84 | +727x |
- grid::grid.draw(x)+ counts |
||
| 398 | +85 |
} |
||
| 399 | +86 | |||
| 400 | +87 |
- #' Update Page Number+ #' @describeIn rtables_access helper function to extract fractions from specified columns in a `TableRow`. |
||
| 401 | +88 | ++ |
+ #' More specifically it extracts the second values from each content cell and checks it is a fraction.+ |
+ |
| 89 |
#' |
|||
| 402 | +90 |
- #' Automatically updates page number.+ #' @return |
||
| 403 | +91 |
- #'+ #' * `h_row_fractions()` returns a `vector` of proportions. |
||
| 404 | +92 |
- #' @param npages number of pages in total+ #' |
||
| 405 | +93 |
- #' @param ... passed on to [decorate_grob()]+ #' @examples |
||
| 406 | +94 |
- #'+ #' # Row fractions |
||
| 407 | +95 |
- #' @return Closure that increments the page number.+ #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]] |
||
| 408 | +96 |
- #'+ #' h_row_fractions(tree_row_elem) |
||
| 409 | +97 |
- #' @keywords internal+ #' |
||
| 410 | +98 |
- decorate_grob_factory <- function(npages, ...) {
+ #' @export |
||
| 411 | -2x | +|||
| 99 | +
- current_page <- 0+ h_row_fractions <- function(table_row, |
|||
| 412 | -2x | +|||
| 100 | +
- function(grob) {
+ col_names = NULL, |
|||
| 413 | -7x | +|||
| 101 | +
- current_page <<- current_page + 1+ col_indices = NULL) {
|
|||
| 414 | -7x | +102 | +243x |
- if (current_page > npages) {
+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
| 415 | -1x | +103 | +243x |
- stop(paste("current page is", current_page, "but max.", npages, "specified."))
+ row_vals <- row_values(table_row)[col_indices] |
| 416 | -+ | |||
| 104 | +243x |
- }+ fractions <- sapply(row_vals, "[", 2L) |
||
| 417 | -6x | +105 | +243x |
- decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
+ checkmate::assert_numeric(fractions, lower = 0, upper = 1) |
| 418 | -+ | |||
| 106 | +243x |
- }+ fractions |
||
| 419 | +107 |
} |
||
| 420 | +108 | |||
| 421 | +109 |
- #' Decorate Set of `grobs` and Add Page Numbering+ #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table. |
||
| 422 | +110 |
#' |
||
| 423 | +111 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param table (`VTableNodeInfo`)\cr an occurrence table or row. |
||
| 424 | +112 |
#' |
||
| 425 | +113 |
- #' Note that this uses the [decorate_grob_factory()] function.+ #' @return |
||
| 426 | +114 |
- #'+ #' * `h_col_counts()` returns a `vector` of column counts. |
||
| 427 | +115 |
- #' @param grobs a list of grid grobs+ #' |
||
| 428 | +116 |
- #' @param ... arguments passed on to [decorate_grob()].+ #' @export |
||
| 429 | +117 |
- #'+ h_col_counts <- function(table, |
||
| 430 | +118 |
- #' @return A decorated grob.+ col_names = NULL, |
||
| 431 | +119 |
- #'+ col_indices = NULL) {
|
||
| 432 | -+ | |||
| 120 | +304x |
- #' @examples+ col_indices <- check_names_indices(table, col_names, col_indices) |
||
| 433 | -+ | |||
| 121 | +304x |
- #' library(ggplot2)+ counts <- col_counts(table)[col_indices] |
||
| 434 | -+ | |||
| 122 | +304x |
- #' library(grid)+ stats::setNames(counts, col_names) |
||
| 435 | +123 |
- #' g <- with(data = iris, {
+ } |
||
| 436 | +124 |
- #' list(+ |
||
| 437 | +125 |
- #' ggplot2::ggplotGrob(+ #' @describeIn rtables_access Helper function to get first row of content table of current table. |
||
| 438 | +126 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) ++ #' |
||
| 439 | +127 |
- #' ggplot2::geom_point()+ #' @return |
||
| 440 | +128 |
- #' ),+ #' * `h_content_first_row()` returns a row from an `rtables` table. |
||
| 441 | +129 |
- #' ggplot2::ggplotGrob(+ #' |
||
| 442 | +130 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) ++ #' @export |
||
| 443 | +131 |
- #' ggplot2::geom_point()+ h_content_first_row <- function(table) {
|
||
| 444 | -+ | |||
| 132 | +27x |
- #' ),+ ct <- content_table(table) |
||
| 445 | -+ | |||
| 133 | +27x |
- #' ggplot2::ggplotGrob(+ tree_children(ct)[[1]] |
||
| 446 | +134 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) ++ } |
||
| 447 | +135 |
- #' ggplot2::geom_point()+ |
||
| 448 | +136 |
- #' ),+ #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree. |
||
| 449 | +137 |
- #' ggplot2::ggplotGrob(+ #' |
||
| 450 | +138 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) ++ #' @return |
||
| 451 | +139 |
- #' ggplot2::geom_point()+ #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf. |
||
| 452 | +140 |
- #' ),+ #' |
||
| 453 | +141 |
- #' ggplot2::ggplotGrob(+ #' @keywords internal |
||
| 454 | +142 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) ++ is_leaf_table <- function(table) {
|
||
| 455 | -+ | |||
| 143 | +168x |
- #' ggplot2::geom_point()+ children <- tree_children(table) |
||
| 456 | -+ | |||
| 144 | +168x |
- #' ),+ child_classes <- unique(sapply(children, class))+ |
+ ||
| 145 | +168x | +
+ identical(child_classes, "ElementaryTable") |
||
| 457 | +146 |
- #' ggplot2::ggplotGrob(+ } |
||
| 458 | +147 |
- #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) ++ |
||
| 459 | +148 |
- #' ggplot2::geom_point()+ #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices. |
||
| 460 | +149 |
- #' )+ #' |
||
| 461 | +150 |
- #' )+ #' @return |
||
| 462 | +151 |
- #' })+ #' * `check_names_indices` returns column indices. |
||
| 463 | +152 |
- #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")+ #' |
||
| 464 | +153 |
- #'+ #' @keywords internal |
||
| 465 | +154 |
- #' draw_grob(lg[[1]])+ check_names_indices <- function(table_row, |
||
| 466 | +155 |
- #' draw_grob(lg[[2]])+ col_names = NULL, |
||
| 467 | +156 |
- #' draw_grob(lg[[6]])+ col_indices = NULL) {
+ |
+ ||
| 157 | +1274x | +
+ if (!is.null(col_names)) {
+ |
+ ||
| 158 | +1231x | +
+ if (!is.null(col_indices)) {
+ |
+ ||
| 159 | +! | +
+ stop(+ |
+ ||
| 160 | +! | +
+ "Inserted both col_names and col_indices when selecting row values. ",+ |
+ ||
| 161 | +! | +
+ "Please choose one." |
||
| 468 | +162 |
- #'+ ) |
||
| 469 | +163 |
- #' @export+ }+ |
+ ||
| 164 | +1231x | +
+ col_indices <- h_col_indices(table_row, col_names) |
||
| 470 | +165 |
- decorate_grob_set <- function(grobs, ...) {
+ } |
||
| 471 | -1x | +166 | +1274x |
- n <- length(grobs)+ if (is.null(col_indices)) {
|
| 472 | -1x | +167 | +37x |
- lgf <- decorate_grob_factory(npages = n, ...)+ ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row)) |
| 473 | -1x | +168 | +37x |
- lapply(grobs, lgf)+ col_indices <- seq_len(ll) |
| 474 | +169 | ++ |
+ }+ |
+ |
| 170 | ++ | + + | +||
| 171 | +1274x | +
+ return(col_indices)+ |
+ ||
| 172 |
}@@ -130196,14 +131981,14 @@ tern coverage - 90.46% |
| 1 |
- #' Patient Counts for Laboratory Events (Worsen From Baseline) by Highest Grade Post-Baseline+ #' Counting Patients Summing Exposure Across All Patients in Columns |
||
| 5 |
- #' Patient count and fraction for laboratory events (worsen from baseline) shift table.+ #' Counting the number of patients and summing analysis value (i.e exposure values) across all patients |
||
| 6 |
- #'+ #' when a column table layout is required. |
||
| 7 |
- #' @inheritParams argument_convention+ #' |
||
| 8 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables including:+ #' @inheritParams argument_convention |
||
| 9 |
- #' * `id` (`string`)\cr subject variable name.+ #' @param ex_var (`character`)\cr name of the variable within `df` containing exposure values. |
||
| 10 |
- #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will be used as label. |
||
| 11 |
- #' * `direction_var` (`string`)\cr see `direction_var` for more details.+ #' @param .stats (`character`)\cr statistics to select for the table. Run |
||
| 12 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade_worsen")`
+ #' `get_stats("analyze_patients_exposure_in_cols")` to see available statistics for this function.
|
||
| 13 |
- #' to see all available statistics.+ #' |
||
| 14 |
- #'+ #' @name summarize_patients_exposure_in_cols |
||
| 15 |
- #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()]+ #' @order 1 |
||
| 16 |
- #'+ NULL |
||
| 17 |
- #' @name abnormal_by_worst_grade_worsen+ |
||
| 18 |
- #' @order 1+ #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers |
||
| 19 |
- NULL+ #' of patients and the sum of exposure across all patients. |
||
| 20 |
-
+ #' |
||
| 21 |
- #' Helper Function to Prepare `ADLB` with Worst Labs+ #' @return |
||
| 22 |
- #'+ #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics: |
||
| 23 |
- #' @description `r lifecycle::badge("stable")`
+ #' * `n_patients`: Number of unique patients in `df`. |
||
| 24 |
- #'+ #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`. |
||
| 25 |
- #' Helper function to prepare a `df` for generate the patient count shift table+ #' |
||
| 26 |
- #'+ #' @keywords internal |
||
| 27 |
- #' @param adlb (`data.frame`)\cr `ADLB` dataframe+ s_count_patients_sum_exposure <- function(df, |
||
| 28 |
- #' @param worst_flag_low (named `vector`)\cr Worst low post-baseline lab grade flag variable+ ex_var = "AVAL", |
||
| 29 |
- #' @param worst_flag_high (named `vector`)\cr Worst high post-baseline lab grade flag variable+ id = "USUBJID", |
||
| 30 |
- #' @param direction_var (`string`)\cr Direction variable specifying the direction of the shift table of interest.+ labelstr = "", |
||
| 31 |
- #' Only lab records flagged by `L`, `H` or `B` are included in the shift table.+ .stats = c("n_patients", "sum_exposure"),
|
||
| 32 |
- #' * `L`: low direction only+ .N_col, # nolint |
||
| 33 |
- #' * `H`: high direction only+ custom_label = NULL) {
|
||
| 34 | -+ | 56x |
- #' * `B`: both low and high directions+ assert_df_with_variables(df, list(ex_var = ex_var, id = id)) |
| 35 | -+ | 56x |
- #'+ checkmate::assert_string(id) |
| 36 | -+ | 56x |
- #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the+ checkmate::assert_string(labelstr) |
| 37 | -+ | 56x |
- #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the+ checkmate::assert_string(custom_label, null.ok = TRUE) |
| 38 | -+ | 56x |
- #' direction specified according to `direction_var`. For instance, for a lab that is+ checkmate::assert_numeric(df[[ex_var]]) |
| 39 | -+ | 56x |
- #' needed for the low direction only, only records flagged by `worst_flag_low` are+ checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
|
| 40 |
- #' selected. For a lab that is needed for both low and high directions, the worst+ |
||
| 41 | -+ | 56x |
- #' low records are selected for the low direction, and the worst high record are selected+ row_label <- if (labelstr != "") {
|
| 42 | -+ | ! |
- #' for the high direction.+ labelstr |
| 43 | -+ | 56x |
- #'+ } else if (!is.null(custom_label)) {
|
| 44 | -+ | 48x |
- #' @seealso [abnormal_by_worst_grade_worsen]+ custom_label |
| 45 |
- #'+ } else {
|
||
| 46 | -+ | 8x |
- #' @examples+ "Total patients numbers/person time" |
| 47 |
- #' library(dplyr)+ } |
||
| 48 |
- #'+ |
||
| 49 | -+ | 56x |
- #' # The direction variable, GRADDR, is based on metadata+ y <- list() |
| 50 |
- #' adlb <- tern_ex_adlb %>%+ |
||
| 51 | -+ | 56x |
- #' mutate(+ if ("n_patients" %in% .stats) {
|
| 52 | -+ | 23x |
- #' GRADDR = case_when(+ y$n_patients <- |
| 53 | -+ | 23x |
- #' PARAMCD == "ALT" ~ "B",+ formatters::with_label( |
| 54 | -+ | 23x |
- #' PARAMCD == "CRP" ~ "L",+ s_num_patients_content( |
| 55 | -+ | 23x |
- #' PARAMCD == "IGA" ~ "H"+ df = df, |
| 56 | -+ | 23x |
- #' )+ .N_col = .N_col, # nolint |
| 57 | -+ | 23x |
- #' ) %>%+ .var = id, |
| 58 | -+ | 23x |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ labelstr = "" |
| 59 | -+ | 23x |
- #'+ )$unique, |
| 60 | -+ | 23x |
- #' df <- h_adlb_worsen(+ row_label |
| 61 |
- #' adlb,+ ) |
||
| 62 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ } |
||
| 63 | -+ | 56x |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ if ("sum_exposure" %in% .stats) {
|
| 64 | -+ | 34x |
- #' direction_var = "GRADDR"+ y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label) |
| 65 |
- #' )+ } |
||
| 66 | -+ | 56x |
- #'+ y |
| 67 |
- #' @export+ } |
||
| 68 |
- h_adlb_worsen <- function(adlb,+ |
||
| 69 |
- worst_flag_low = NULL,+ #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in |
||
| 70 |
- worst_flag_high = NULL,+ #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in |
||
| 71 |
- direction_var) {
+ #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`. |
||
| 72 | -5x | +
- checkmate::assert_string(direction_var)+ #' |
|
| 73 | -5x | +
- checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
+ #' @return |
|
| 74 | -5x | +
- assert_df_with_variables(adlb, list("Col" = direction_var))
+ #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()]. |
|
| 75 |
-
+ #' |
||
| 76 | -5x | +
- if (any(unique(adlb[[direction_var]]) == "H")) {
+ #' @examples |
|
| 77 | -4x | +
- assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
+ #' a_count_patients_sum_exposure( |
|
| 78 |
- }+ #' df = df, |
||
| 79 |
-
+ #' var = "SEX", |
||
| 80 | -5x | +
- if (any(unique(adlb[[direction_var]]) == "L")) {
+ #' .N_col = nrow(df), |
|
| 81 | -4x | +
- assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
+ #' .stats = "n_patients" |
|
| 82 |
- }+ #' ) |
||
| 83 |
-
+ #' |
||
| 84 | -5x | +
- if (any(unique(adlb[[direction_var]]) == "B")) {
+ #' @export |
|
| 85 | -3x | +
- assert_df_with_variables(+ a_count_patients_sum_exposure <- function(df, |
|
| 86 | -3x | +
- adlb,+ var = NULL, |
|
| 87 | -3x | +
- list(+ ex_var = "AVAL", |
|
| 88 | -3x | +
- "Low" = names(worst_flag_low),+ id = "USUBJID", |
|
| 89 | -3x | +
- "High" = names(worst_flag_high)+ add_total_level = FALSE, |
|
| 90 |
- )+ custom_label = NULL, |
||
| 91 |
- )+ labelstr = "", |
||
| 92 |
- }+ .N_col, # nolint |
||
| 93 |
-
+ .stats, |
||
| 94 |
- # extract patients with worst post-baseline lab, either low or high or both+ .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
|
||
| 95 | -5x | +32x |
- worst_flag <- c(worst_flag_low, worst_flag_high)+ checkmate::assert_flag(add_total_level) |
| 96 | -5x | +
- col_names <- names(worst_flag)+ |
|
| 97 | -5x | +32x |
- filter_values <- worst_flag+ if (!is.null(var)) {
|
| 98 | -5x | +21x |
- temp <- Map(+ assert_df_with_variables(df, list(var = var)) |
| 99 | -5x | +21x |
- function(x, y) which(adlb[[x]] == y),+ df[[var]] <- as.factor(df[[var]]) |
| 100 | -5x | +
- col_names,+ } |
|
| 101 | -5x | +
- filter_values+ |
|
| 102 | -+ | 32x |
- )+ y <- list() |
| 103 | -5x | +32x |
- position_satisfy_filters <- Reduce(union, temp)+ if (is.null(var)) {
|
| 104 | -+ | 11x |
-
+ y[[.stats]] <- list(Total = s_count_patients_sum_exposure( |
| 105 | -+ | 11x |
- # select variables of interest+ df = df, |
| 106 | -5x | +11x |
- adlb_f <- adlb[position_satisfy_filters, ]+ ex_var = ex_var, |
| 107 | -+ | 11x |
-
+ id = id, |
| 108 | -+ | 11x |
- # generate subsets for different directionality+ labelstr = labelstr, |
| 109 | -5x | +11x |
- adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]+ .N_col = .N_col, |
| 110 | -5x | +11x |
- adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]+ .stats = .stats, |
| 111 | -5x | +11x |
- adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]+ custom_label = custom_label |
| 112 | -+ | 11x |
-
+ )[[.stats]]) |
| 113 |
- # for labs requiring both high and low, data is duplicated and will be stacked on top of each other+ } else {
|
||
| 114 | -5x | +21x |
- adlb_f_b_h <- adlb_f_b+ for (lvl in levels(df[[var]])) {
|
| 115 | -5x | +42x |
- adlb_f_b_l <- adlb_f_b+ y[[.stats]][[lvl]] <- s_count_patients_sum_exposure( |
| 116 | -+ | 42x |
-
+ df = subset(df, get(var) == lvl), |
| 117 | -+ | 42x |
- # extract data with worst lab+ ex_var = ex_var, |
| 118 | -5x | +42x |
- if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
+ id = id, |
| 119 | -+ | 42x |
- # change H to High, L to Low+ labelstr = labelstr, |
| 120 | -3x | +42x |
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ .N_col = .N_col, |
| 121 | -3x | +42x |
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ .stats = .stats, |
| 122 | -+ | 42x |
-
+ custom_label = lvl |
| 123 | -+ | 42x |
- # change, B to High and Low+ )[[.stats]] |
| 124 | -3x | +
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ } |
|
| 125 | -3x | +21x |
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ if (add_total_level) {
|
| 126 | -+ | 2x |
-
+ y[[.stats]][["Total"]] <- s_count_patients_sum_exposure( |
| 127 | -3x | +2x |
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ df = df, |
| 128 | -3x | +2x |
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ ex_var = ex_var, |
| 129 | -3x | +2x |
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ id = id, |
| 130 | -3x | +2x |
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ labelstr = labelstr, |
| 131 | -+ | 2x |
-
+ .N_col = .N_col, |
| 132 | -3x | +2x |
- out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)+ .stats = .stats, |
| 133 | 2x |
- } else if (!is.null(worst_flag_high)) {
+ custom_label = custom_label |
|
| 134 | -1x | +2x |
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ )[[.stats]] |
| 135 | -1x | +
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ } |
|
| 136 |
-
+ } |
||
| 137 | -1x | +
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ |
|
| 138 | -1x | +32x |
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ in_rows(.list = y[[.stats]], .formats = .formats[[.stats]]) |
| 139 |
-
+ } |
||
| 140 | -1x | +
- out <- rbind(adlb_out_h, adlb_out_b_h)+ |
|
| 141 | -1x | +
- } else if (!is.null(worst_flag_low)) {
+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
|
| 142 | -1x | +
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ #' function arguments and additional format arguments. This function is a wrapper for |
|
| 143 | -1x | +
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()]. |
|
| 144 |
-
+ #' |
||
| 145 | -1x | +
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' @return |
|
| 146 | -1x | +
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
|
| 147 |
-
+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 148 | -1x | +
- out <- rbind(adlb_out_l, adlb_out_b_l)+ #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
|
| 149 |
- }+ #' columns, to the table layout. |
||
| 150 |
-
+ #' |
||
| 151 |
- # label+ #' @examples |
||
| 152 | -5x | +
- formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)+ #' lyt5 <- basic_table() %>% |
|
| 153 |
- # NA+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) |
||
| 154 | -5x | +
- out+ #' |
|
| 155 |
- }+ #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl) |
||
| 156 |
-
+ #' result5 |
||
| 157 |
- #' Helper Function to Analyze Patients for [s_count_abnormal_lab_worsen_by_baseline()]+ #' |
||
| 158 |
- #'+ #' lyt6 <- basic_table() %>% |
||
| 159 |
- #' @description `r lifecycle::badge("stable")`
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure") |
||
| 161 |
- #' Helper function to count the number of patients and the fraction of patients according to+ #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl) |
||
| 162 |
- #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,+ #' result6 |
||
| 163 |
- #' and the direction of interest specified in `direction_var`.+ #' |
||
| 164 |
- #'+ #' @export |
||
| 165 |
- #' @inheritParams argument_convention+ #' @order 3 |
||
| 166 |
- #' @inheritParams h_adlb_worsen+ summarize_patients_exposure_in_cols <- function(lyt, # nolint |
||
| 167 |
- #' @param baseline_var (`string`)\cr baseline lab grade variable+ var, |
||
| 168 |
- #'+ ex_var = "AVAL", |
||
| 169 |
- #' @return `h_worsen_counter()` returns the counts and fraction of patients+ id = "USUBJID", |
||
| 170 |
- #' whose worst post-baseline lab grades are worse than their baseline grades, for+ add_total_level = FALSE, |
||
| 171 |
- #' post-baseline worst grades "1", "2", "3", "4" and "Any".+ custom_label = NULL, |
||
| 172 |
- #'+ col_split = TRUE, |
||
| 173 |
- #' @seealso [abnormal_by_worst_grade_worsen]+ na_str = default_na_str(), |
||
| 174 |
- #'+ ..., |
||
| 175 |
- #' @examples+ .stats = c("n_patients", "sum_exposure"),
|
||
| 176 |
- #' library(dplyr)+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
||
| 177 |
- #'+ .indent_mods = NULL) {
|
||
| 178 | -+ | 3x |
- #' # The direction variable, GRADDR, is based on metadata+ extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...) |
| 179 |
- #' adlb <- tern_ex_adlb %>%+ |
||
| 180 | -+ | 3x |
- #' mutate(+ if (col_split) {
|
| 181 | -+ | 3x |
- #' GRADDR = case_when(+ lyt <- split_cols_by_multivar( |
| 182 | -+ | 3x |
- #' PARAMCD == "ALT" ~ "B",+ lyt = lyt, |
| 183 | -+ | 3x |
- #' PARAMCD == "CRP" ~ "L",+ vars = rep(var, length(.stats)), |
| 184 | -+ | 3x |
- #' PARAMCD == "IGA" ~ "H"+ varlabels = .labels[.stats], |
| 185 | -+ | 3x |
- #' )+ extra_args = list(.stats = .stats) |
| 186 |
- #' ) %>%+ ) |
||
| 187 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ } |
||
| 188 | -+ | 3x |
- #'+ summarize_row_groups( |
| 189 | -+ | 3x |
- #' df <- h_adlb_worsen(+ lyt = lyt, |
| 190 | -+ | 3x |
- #' adlb,+ var = var, |
| 191 | -+ | 3x |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ cfun = a_count_patients_sum_exposure, |
| 192 | -+ | 3x |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ na_str = na_str, |
| 193 | -+ | 3x |
- #' direction_var = "GRADDR"+ extra_args = extra_args |
| 194 |
- #' )+ ) |
||
| 195 |
- #'+ } |
||
| 196 |
- #' # `h_worsen_counter`+ |
||
| 197 |
- #' h_worsen_counter(+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
||
| 198 |
- #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),+ #' function arguments and additional format arguments. This function is a wrapper for |
||
| 199 |
- #' id = "USUBJID",+ #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()]. |
||
| 200 |
- #' .var = "ATOXGR",+ #' |
||
| 201 |
- #' baseline_var = "BTOXGR",+ #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required |
||
| 202 |
- #' direction_var = "GRADDR"+ #' column split has been done already earlier in the layout pipe. |
||
| 203 |
- #' )+ #' |
||
| 204 |
- #'+ #' @return |
||
| 205 |
- #' @export+ #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
||
| 206 |
- h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 207 | -17x | +
- checkmate::assert_string(id)+ #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
|
| 208 | -17x | +
- checkmate::assert_string(.var)+ #' columns, to the table layout. |
|
| 209 | -17x | +
- checkmate::assert_string(baseline_var)+ #' |
|
| 210 | -17x | +
- checkmate::assert_scalar(unique(df[[direction_var]]))+ #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows, |
|
| 211 | -17x | +
- checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
+ #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple |
|
| 212 | -17x | +
- assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))+ #' pages when pagination is used. |
|
| 213 |
-
+ #' |
||
| 214 |
- # remove post-baseline missing+ #' @examples |
||
| 215 | -17x | +
- df <- df[df[[.var]] != "<Missing>", ]+ #' set.seed(1) |
|
| 216 |
-
+ #' df <- data.frame( |
||
| 217 |
- # obtain directionality+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
||
| 218 | -17x | +
- direction <- unique(df[[direction_var]])+ #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
|
|
| 219 |
-
+ #' SEX = c(rep("Female", 6), rep("Male", 6)),
|
||
| 220 | -17x | +
- if (direction == "Low") {
+ #' AVAL = as.numeric(sample(seq(1, 20), 12)), |
|
| 221 | -10x | +
- grade <- -1:-4+ #' stringsAsFactors = TRUE |
|
| 222 | -10x | +
- worst_grade <- -4+ #' ) |
|
| 223 | -7x | +
- } else if (direction == "High") {
+ #' adsl <- data.frame( |
|
| 224 | -7x | +
- grade <- 1:4+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
|
| 225 | -7x | +
- worst_grade <- 4+ #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
|
|
| 226 |
- }+ #' SEX = c(rep("Female", 2), rep("Male", 2)),
|
||
| 227 |
-
+ #' stringsAsFactors = TRUE |
||
| 228 | -17x | +
- if (nrow(df) > 0) {
+ #' ) |
|
| 229 | -17x | +
- by_grade <- lapply(grade, function(i) {
+ #' |
|
| 230 |
- # filter baseline values that is less than i or <Missing>+ #' lyt <- basic_table() %>% |
||
| 231 | -68x | +
- df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
|
| 232 |
- # num: number of patients with post-baseline worst lab equal to i+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>% |
||
| 233 | -68x | +
- num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE) |
|
| 234 |
- # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction+ #' result <- build_table(lyt, df = df, alt_counts_df = adsl) |
||
| 235 | -68x | +
- denom <- length(unique(df_temp[[id]]))+ #' result |
|
| 236 | -68x | +
- rm(df_temp)+ #' |
|
| 237 | -68x | +
- c(num = num, denom = denom)+ #' lyt2 <- basic_table() %>% |
|
| 238 |
- })+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
||
| 239 |
- } else {
+ #' summarize_patients_exposure_in_cols( |
||
| 240 | -! | +
- by_grade <- lapply(1, function(i) {
+ #' var = "AVAL", col_split = TRUE, |
|
| 241 | -! | +
- c(num = 0, denom = 0)+ #' .stats = "n_patients", custom_label = "some custom label" |
|
| 242 |
- })+ #' ) %>% |
||
| 243 |
- }+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL") |
||
| 244 |
-
+ #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl) |
||
| 245 | -17x | +
- names(by_grade) <- as.character(seq_along(by_grade))+ #' result2 |
|
| 246 |
-
+ #' |
||
| 247 |
- # baseline grade less 4 or missing+ #' lyt3 <- basic_table() %>% |
||
| 248 | -17x | +
- df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL") |
|
| 249 |
-
+ #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl) |
||
| 250 |
- # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction+ #' result3 |
||
| 251 | -17x | +
- denom <- length(unique(df_temp[, id, drop = TRUE]))+ #' |
|
| 252 |
-
+ #' # Adding total levels and custom label |
||
| 253 |
- # condition 1: missing baseline and in the direction of abnormality+ #' lyt4 <- basic_table( |
||
| 254 | -17x | +
- con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)+ #' show_colcounts = TRUE |
|
| 255 | -17x | +
- df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]+ #' ) %>% |
|
| 256 |
-
+ #' analyze_patients_exposure_in_cols( |
||
| 257 |
- # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline+ #' var = "ARMCD", |
||
| 258 | -17x | +
- if (direction == "Low") {
+ #' col_split = TRUE, |
|
| 259 | -10x | +
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))+ #' add_total_level = TRUE, |
|
| 260 |
- } else {
+ #' custom_label = "TOTAL" |
||
| 261 | -7x | +
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))+ #' ) %>% |
|
| 262 |
- }+ #' append_topleft(c("", "Sex"))
|
||
| 263 |
-
+ #' |
||
| 264 |
- # number of patients satisfy either conditions 1 or 2+ #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl) |
||
| 265 | -17x | +
- num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))+ #' result4 |
|
| 266 |
-
+ #' |
||
| 267 | -17x | +
- list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
+ #' @export |
|
| 268 |
- }+ #' @order 2 |
||
| 269 |
-
+ analyze_patients_exposure_in_cols <- function(lyt, # nolint |
||
| 270 |
- #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline+ var = NULL, |
||
| 271 |
- #' lab grades are worse than their baseline grades.+ ex_var = "AVAL", |
||
| 272 |
- #'+ id = "USUBJID", |
||
| 273 |
- #' @return+ add_total_level = FALSE, |
||
| 274 |
- #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst+ custom_label = NULL, |
||
| 275 |
- #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades+ col_split = TRUE, |
||
| 276 |
- #' "1", "2", "3", "4" and "Any".+ na_str = default_na_str(), |
||
| 277 |
- #'+ .stats = c("n_patients", "sum_exposure"),
|
||
| 278 |
- #' @keywords internal+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
||
| 279 |
- s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint+ .indent_mods = 0L, |
||
| 280 |
- .var = "ATOXGR",+ ...) {
|
||
| 281 | -+ | 6x |
- variables = list(+ extra_args <- list( |
| 282 | -+ | 6x |
- id = "USUBJID",+ var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ... |
| 283 |
- baseline_var = "BTOXGR",+ ) |
||
| 284 |
- direction_var = "GRADDR"+ |
||
| 285 | -+ | 6x |
- )) {
+ if (col_split) {
|
| 286 | -1x | +4x |
- checkmate::assert_string(.var)+ lyt <- split_cols_by_multivar( |
| 287 | -1x | +4x |
- checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
+ lyt = lyt, |
| 288 | -1x | +4x |
- checkmate::assert_string(variables$id)+ vars = rep(ex_var, length(.stats)), |
| 289 | -1x | +4x |
- checkmate::assert_string(variables$baseline_var)+ varlabels = .labels[.stats], |
| 290 | -1x | +4x |
- checkmate::assert_string(variables$direction_var)+ extra_args = list(.stats = .stats) |
| 291 | -1x | +
- assert_df_with_variables(df, c(aval = .var, variables[1:3]))+ ) |
|
| 292 | -1x | +
- assert_list_of_variables(variables)+ } |
|
| 293 | -+ | 6x |
-
+ lyt <- lyt %>% analyze_colvars( |
| 294 | -1x | +6x |
- h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)+ afun = a_count_patients_sum_exposure, |
| 295 | -+ | 6x |
- }+ indent_mod = .indent_mods, |
| 296 | -+ | 6x |
-
+ na_str = na_str, |
| 297 | -+ | 6x |
-
+ extra_args = extra_args |
| 298 |
- #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun`+ ) |
||
| 299 | -+ | 6x |
- #' in `count_abnormal_lab_worsen_by_baseline()`.+ lyt |
| 300 |
- #'- |
- ||
| 301 | -- |
- #' @return- |
- |
| 302 | -- |
- #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with+ } |
| 303 | +1 |
- #' formatted [rtables::CellValue()].+ #' Get default statistical methods and their associated formats, labels, and indent modifiers |
||
| 304 | +2 |
#' |
||
| 305 | -- |
- #' @keywords internal- |
- ||
| 306 | -- |
- a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint- |
- ||
| 307 | -- |
- s_count_abnormal_lab_worsen_by_baseline,- |
- ||
| 308 | +3 |
- .formats = c(fraction = format_fraction),+ #' @description `r lifecycle::badge("experimental")`
|
||
| 309 | +4 |
- .ungroup_stats = "fraction"+ #' |
||
| 310 | +5 |
- )+ #' Utility functions to get valid statistic methods for different method groups |
||
| 311 | +6 |
-
+ #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers |
||
| 312 | +7 |
- #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function+ #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be |
||
| 313 | +8 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' seen in [analyze_vars()]. See notes to understand why this is experimental. |
||
| 314 | +9 |
#' |
||
| 315 | +10 |
- #' @return+ #' @param stats (`character`)\cr statistical methods to get defaults for. |
||
| 316 | +11 |
- #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting+ #' |
||
| 317 | +12 |
- #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted+ #' @details |
||
| 318 | +13 |
- #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout.+ #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`. |
||
| 319 | +14 |
#' |
||
| 320 | -- |
- #' @examples- |
- ||
| 321 | +15 |
- #' library(dplyr)+ #' @note |
||
| 322 | +16 |
- #'+ #' These defaults are experimental because we use the names of functions to retrieve the default |
||
| 323 | +17 |
- #' # The direction variable, GRADDR, is based on metadata+ #' statistics. This should be generalized in groups of methods according to more reasonable groupings. |
||
| 324 | +18 |
- #' adlb <- tern_ex_adlb %>%+ #' |
||
| 325 | +19 |
- #' mutate(+ #' @name default_stats_formats_labels |
||
| 326 | +20 |
- #' GRADDR = case_when(+ NULL |
||
| 327 | +21 |
- #' PARAMCD == "ALT" ~ "B",+ |
||
| 328 | +22 |
- #' PARAMCD == "CRP" ~ "L",+ #' @describeIn default_stats_formats_labels Get statistics available for a given method |
||
| 329 | +23 |
- #' PARAMCD == "IGA" ~ "H"+ #' group (analyze function). |
||
| 330 | +24 |
- #' )+ #' |
||
| 331 | +25 |
- #' ) %>%+ #' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function) |
||
| 332 | +26 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' to retrieve default statistics for. A character vector can be used to specify more than one statistical |
||
| 333 | +27 |
- #'+ #' method group. |
||
| 334 | +28 |
- #' df <- h_adlb_worsen(+ #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group. |
||
| 335 | +29 |
- #' adlb,+ #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains |
||
| 336 | +30 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' `"analyze_vars_counts"`) be added to the statistical methods? |
||
| 337 | +31 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' |
||
| 338 | +32 |
- #' direction_var = "GRADDR"+ #' @return |
||
| 339 | +33 |
- #' )+ #' * `get_stats()` returns a `character` vector of statistical methods. |
||
| 340 | +34 |
#' |
||
| 341 | +35 |
- #' basic_table() %>%+ #' @examples |
||
| 342 | +36 |
- #' split_cols_by("ARMCD") %>%
+ #' # analyze_vars is numeric |
||
| 343 | +37 |
- #' add_colcounts() %>%+ #' num_stats <- get_stats("analyze_vars_numeric") # also the default
|
||
| 344 | +38 |
- #' split_rows_by("PARAMCD") %>%
+ #' |
||
| 345 | +39 |
- #' split_rows_by("GRADDR") %>%
+ #' # Other type |
||
| 346 | +40 |
- #' count_abnormal_lab_worsen_by_baseline(+ #' cnt_stats <- get_stats("analyze_vars_counts")
|
||
| 347 | +41 |
- #' var = "ATOXGR",+ #' |
||
| 348 | +42 |
- #' variables = list(+ #' # Weirdly taking the pval from count_occurrences |
||
| 349 | +43 |
- #' id = "USUBJID",+ #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
|
||
| 350 | +44 |
- #' baseline_var = "BTOXGR",+ #' |
||
| 351 | +45 |
- #' direction_var = "GRADDR"+ #' # All count_occurrences |
||
| 352 | +46 |
- #' )+ #' all_cnt_occ <- get_stats("count_occurrences")
|
||
| 353 | +47 |
- #' ) %>%+ #' |
||
| 354 | +48 |
- #' append_topleft("Direction of Abnormality") %>%
+ #' # Multiple |
||
| 355 | +49 |
- #' build_table(df = df, alt_counts_df = tern_ex_adsl)+ #' get_stats(c("count_occurrences", "analyze_vars_counts"))
|
||
| 356 | +50 |
#' |
||
| 357 | +51 |
#' @export |
||
| 358 | +52 |
- #' @order 2+ get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
|
||
| 359 | -+ | |||
| 53 | +428x |
- count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint+ checkmate::assert_character(method_groups) |
||
| 360 | -+ | |||
| 54 | +428x |
- var,+ checkmate::assert_character(stats_in, null.ok = TRUE) |
||
| 361 | -+ | |||
| 55 | +428x |
- variables = list(+ checkmate::assert_flag(add_pval) |
||
| 362 | +56 |
- id = "USUBJID",+ |
||
| 363 | +57 |
- baseline_var = "BTOXGR",+ # Default is still numeric |
||
| 364 | -+ | |||
| 58 | +428x |
- direction_var = "GRADDR"+ if (any(method_groups == "analyze_vars")) {
|
||
| 365 | -+ | |||
| 59 | +2x |
- ),+ method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric" |
||
| 366 | +60 |
- na_str = default_na_str(),+ } |
||
| 367 | +61 |
- nested = TRUE,+ |
||
| 368 | -+ | |||
| 62 | +428x |
- ...,+ type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
|
||
| 369 | +63 |
- table_names = NULL,+ |
||
| 370 | +64 |
- .stats = NULL,+ # Defaults for loop |
||
| 371 | -+ | |||
| 65 | +428x |
- .formats = NULL,+ out <- NULL |
||
| 372 | +66 |
- .labels = NULL,+ |
||
| 373 | +67 |
- .indent_mods = NULL) {
+ # Loop for multiple method groups |
||
| 374 | -1x | +68 | +428x |
- checkmate::assert_string(var)+ for (mgi in method_groups) {
+ |
+
| 69 | +438x | +
+ out_tmp <- if (mgi %in% names(tern_default_stats)) {
+ |
+ ||
| 70 | +438x | +
+ tern_default_stats[[mgi]] |
||
| 375 | +71 |
-
+ } else {
|
||
| 376 | -1x | +|||
| 72 | +! |
- extra_args <- list(variables = variables, ...)+ stop("The selected method group (", mgi, ") has no default statistical method.")
|
||
| 377 | +73 |
-
+ } |
||
| 378 | -1x | +74 | +438x |
- afun <- make_afun(+ out <- unique(c(out, out_tmp)) |
| 379 | -1x | +|||
| 75 | +
- a_count_abnormal_lab_worsen_by_baseline,+ } |
|||
| 380 | -1x | +|||
| 76 | +
- .stats = .stats,+ |
|||
| 381 | -1x | +|||
| 77 | +
- .formats = .formats,+ # If you added pval to the stats_in you certainly want it |
|||
| 382 | -1x | +78 | +428x |
- .labels = .labels,+ if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
|
| 383 | -1x | +79 | +24x |
- .indent_mods = .indent_mods+ stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
|
| 384 | +80 |
- )+ |
||
| 385 | +81 |
-
+ # Must be only one value between choices |
||
| 386 | -1x | +82 | +24x |
- lyt <- analyze(+ checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
|
| 387 | -1x | +|||
| 83 | +
- lyt = lyt,+ |
|||
| 388 | -1x | +|||
| 84 | +
- vars = var,+ # Mismatch with counts and numeric |
|||
| 389 | -1x | +85 | +23x |
- afun = afun,+ if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
|
| 390 | -1x | +86 | +23x |
- na_str = na_str,+ any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
|
| 391 | -1x | +87 | +2x |
- nested = nested,+ stop( |
| 392 | -1x | +88 | +2x |
- extra_args = extra_args,+ "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
|
| 393 | -1x | +89 | +2x |
- show_labels = "hidden"+ type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")), |
| 394 | -+ | |||
| 90 | +2x |
- )+ " instead." |
||
| 395 | +91 |
-
+ ) |
||
| 396 | -1x | +|||
| 92 | +
- lyt+ } |
|||
| 397 | +93 |
- }+ |
| 1 | +94 |
- #' Compare Variables Between Groups+ # Lets add it even if present (thanks to unique) |
||
| 2 | -+ | |||
| 95 | +21x |
- #'+ add_pval <- TRUE |
||
| 3 | +96 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +97 |
- #'+ |
||
| 5 | +98 |
- #' Comparison with a reference group for different `x` objects.+ # Mainly used in "analyze_vars" but it could be necessary elsewhere |
||
| 6 | -+ | |||
| 99 | +425x |
- #'+ if (isTRUE(add_pval)) {
|
||
| 7 | -+ | |||
| 100 | +25x |
- #' @inheritParams argument_convention+ if (any(grepl("counts", method_groups))) {
|
||
| 8 | -+ | |||
| 101 | +10x |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("analyze_vars_numeric")` to see
+ out <- unique(c(out, "pval_counts")) |
||
| 9 | +102 |
- #' statistics available for numeric variables, and `get_stats("analyze_vars_counts")` for statistics available
+ } else {
|
||
| 10 | -+ | |||
| 103 | +15x |
- #' for non-numeric variables.+ out <- unique(c(out, "pval")) |
||
| 11 | +104 |
- #'+ } |
||
| 12 | +105 |
- #' @note+ } |
||
| 13 | +106 |
- #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions+ |
||
| 14 | +107 |
- #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would+ # Filtering for stats_in (character vector) |
||
| 15 | -+ | |||
| 108 | +425x |
- #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted+ if (!is.null(stats_in)) {
|
||
| 16 | -+ | |||
| 109 | +396x |
- #' for as explicit factor levels.+ out <- intersect(stats_in, out) # It orders them too |
||
| 17 | +110 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ } |
||
| 18 | +111 |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ |
||
| 19 | +112 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ # If intersect did not find matches (and no pval?) -> error |
||
| 20 | -+ | |||
| 113 | +425x |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ if (length(out) == 0) {
|
||
| 21 | -+ | |||
| 114 | +2x |
- #' * For character variables, automatic conversion to factor does not guarantee that the table+ stop( |
||
| 22 | -+ | |||
| 115 | +2x |
- #' will be generated correctly. In particular for sparse tables this very likely can fail.+ "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
|
||
| 23 | -+ | |||
| 116 | +2x |
- #' Therefore it is always better to manually convert character variables to factors during pre-processing.+ " do not have the required default statistical methods:\n", |
||
| 24 | -+ | |||
| 117 | +2x |
- #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison+ paste0(stats_in, collapse = " ") |
||
| 25 | +118 |
- #' is well defined.+ ) |
||
| 26 | +119 |
- #'+ } |
||
| 27 | +120 |
- #' @seealso Relevant constructor function [create_afun_compare()], [s_summary()] which is used internally+ |
||
| 28 | -+ | |||
| 121 | +423x |
- #' to compute a summary within `s_compare()`, and [a_compare()] which is used (with `compare = TRUE`) as the analysis+ out |
||
| 29 | +122 |
- #' function for `compare_vars()`.+ } |
||
| 30 | +123 |
- #'+ |
||
| 31 | +124 |
- #' @name compare_variables+ #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics. |
||
| 32 | +125 |
- #' @include analyze_variables.R+ #' |
||
| 33 | +126 |
- #' @order 1+ #' @param formats_in (named `vector`) \cr inserted formats to replace defaults. It can be a |
||
| 34 | +127 |
- NULL+ #' character vector from [formatters::list_valid_format_labels()] or a custom format function. |
||
| 35 | +128 |
-
+ #' |
||
| 36 | +129 |
- #' @describeIn compare_variables S3 generic function to produce a comparison summary.+ #' @return |
||
| 37 | +130 |
- #'+ #' * `get_formats_from_stats()` returns a named vector of formats (if present in either |
||
| 38 | +131 |
- #' @return+ #' `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from |
||
| 39 | +132 |
- #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values.+ #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]). |
||
| 40 | +133 |
#' |
||
| 41 | +134 |
- #' @export+ #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and |
||
| 42 | +135 |
- s_compare <- function(x,+ #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
|
||
| 43 | +136 |
- .ref_group,+ #' |
||
| 44 | +137 |
- .in_ref_col,+ #' @examples |
||
| 45 | +138 |
- ...) {
+ #' # Defaults formats |
||
| 46 | -31x | +|||
| 139 | +
- UseMethod("s_compare", x)
+ #' get_formats_from_stats(num_stats) |
|||
| 47 | +140 |
- }+ #' get_formats_from_stats(cnt_stats) |
||
| 48 | +141 |
-
+ #' get_formats_from_stats(only_pval) |
||
| 49 | +142 |
- #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test+ #' get_formats_from_stats(all_cnt_occ) |
||
| 50 | +143 |
- #' to calculate the p-value.+ #' |
||
| 51 | +144 |
- #'+ #' # Addition of customs |
||
| 52 | +145 |
- #' @method s_compare numeric+ #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
|
||
| 53 | +146 |
- #'+ #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
|
||
| 54 | +147 |
- #' @examples+ #' |
||
| 55 | +148 |
- #' # `s_compare.numeric`+ #' @seealso [formatting_functions] |
||
| 56 | +149 |
#' |
||
| 57 | +150 |
- #' ## Usual case where both this and the reference group vector have more than 1 value.+ #' @export |
||
| 58 | +151 |
- #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)+ get_formats_from_stats <- function(stats, formats_in = NULL) {
|
||
| 59 | -+ | |||
| 152 | +416x |
- #'+ checkmate::assert_character(stats, min.len = 1) |
||
| 60 | +153 |
- #' ## If one group has not more than 1 value, then p-value is not calculated.+ # It may be a list if there is a function in the formats |
||
| 61 | -+ | |||
| 154 | +416x |
- #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)+ if (checkmate::test_list(formats_in, null.ok = TRUE)) {
|
||
| 62 | -+ | |||
| 155 | +357x |
- #'+ checkmate::assert_list(formats_in, null.ok = TRUE) |
||
| 63 | +156 |
- #' ## Empty numeric does not fail, it returns NA-filled items and no p-value.+ # Or it may be a vector of characters |
||
| 64 | +157 |
- #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)+ } else {
|
||
| 65 | -+ | |||
| 158 | +59x |
- #'+ checkmate::assert_character(formats_in, null.ok = TRUE) |
||
| 66 | +159 |
- #' @export+ } |
||
| 67 | +160 |
- s_compare.numeric <- function(x,+ |
||
| 68 | +161 |
- .ref_group,+ # Extract global defaults |
||
| 69 | -+ | |||
| 162 | +416x |
- .in_ref_col,+ which_fmt <- match(stats, names(tern_default_formats)) |
||
| 70 | +163 |
- ...) {
+
|
||
| 71 | -15x | +|||
| 164 | +
- checkmate::assert_numeric(x)+ # Select only needed formats from stats |
|||
| 72 | -15x | +165 | +416x |
- checkmate::assert_numeric(.ref_group)+ ret <- vector("list", length = length(stats)) # Returning a list is simpler
|
| 73 | -15x | +166 | +416x |
- checkmate::assert_flag(.in_ref_col)+ ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]] |
| 74 | +167 | |||
| 75 | -15x | +168 | +416x |
- y <- s_summary.numeric(x = x, ...)+ out <- setNames(ret, stats) |
| 76 | +169 | |||
| 77 | -15x | +|||
| 170 | +
- y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
+ # Modify some with custom formats |
|||
| 78 | -11x | +171 | +416x |
- stats::t.test(x, .ref_group)$p.value+ if (!is.null(formats_in)) {
|
| 79 | +172 |
- } else {
+ # Stats is the main |
||
| 80 | -4x | +173 | +61x |
- character()+ common_names <- intersect(names(out), names(formats_in))+ |
+
| 174 | +61x | +
+ out[common_names] <- formats_in[common_names] |
||
| 81 | +175 |
} |
||
| 82 | +176 | |||
| 83 | -15x | +177 | +416x |
- y+ out |
| 84 | +178 |
} |
||
| 85 | +179 | |||
| 86 | +180 |
- #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test+ #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics. |
||
| 87 | +181 |
- #' to calculate the p-value.+ #' |
||
| 88 | +182 |
- #'+ #' @param labels_in (named `vector` of `character`)\cr inserted labels to replace defaults. |
||
| 89 | +183 |
- #' @param denom (`string`)\cr choice of denominator for factor proportions,+ #' @param row_nms (`character`)\cr row names. Levels of a `factor` or `character` variable, each |
||
| 90 | +184 |
- #' can only be `n` (number of values in this row and column intersection).+ #' of which the statistics in `.stats` will be calculated for. If this parameter is set, these |
||
| 91 | +185 |
- #'+ #' variable levels will be used as the defaults, and the names of the given custom values should |
||
| 92 | +186 |
- #' @method s_compare factor+ #' correspond to levels (or have format `statistic.level`) instead of statistics. Can also be |
||
| 93 | +187 |
- #'+ #' variable names if rows correspond to different variables instead of levels. Defaults to `NULL`. |
||
| 94 | +188 |
- #' @examples+ #' |
||
| 95 | +189 |
- #' # `s_compare.factor`+ #' @return |
||
| 96 | +190 |
- #'+ #' * `get_labels_from_stats()` returns a named `character` vector of labels (if present in either |
||
| 97 | +191 |
- #' ## Basic usage:+ #' `tern_default_labels` or `labels_in`, otherwise `NULL`). |
||
| 98 | +192 |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ #' |
||
| 99 | +193 |
- #' y <- factor(c("a", "b", "c"))
+ #' @examples |
||
| 100 | +194 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)+ #' # Defaults labels |
||
| 101 | +195 |
- #'+ #' get_labels_from_stats(num_stats) |
||
| 102 | +196 |
- #' ## Management of NA values.+ #' get_labels_from_stats(cnt_stats) |
||
| 103 | +197 |
- #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
+ #' get_labels_from_stats(only_pval) |
||
| 104 | +198 |
- #' y <- explicit_na(factor(c("a", "b", "c", NA)))
+ #' get_labels_from_stats(all_cnt_occ) |
||
| 105 | +199 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ #' |
||
| 106 | +200 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ #' # Addition of customs |
||
| 107 | +201 |
- #'+ #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
|
||
| 108 | +202 |
- #' @export+ #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
|
||
| 109 | +203 |
- s_compare.factor <- function(x,+ #' |
||
| 110 | +204 |
- .ref_group,+ #' @export |
||
| 111 | +205 |
- .in_ref_col,+ get_labels_from_stats <- function(stats, labels_in = NULL, row_nms = NULL) {
|
||
| 112 | -+ | |||
| 206 | +401x |
- denom = "n",+ checkmate::assert_character(stats, min.len = 1) |
||
| 113 | -+ | |||
| 207 | +401x |
- na.rm = TRUE, # nolint+ checkmate::assert_character(row_nms, null.ok = TRUE) |
||
| 114 | +208 |
- ...) {
- |
- ||
| 115 | -12x | -
- checkmate::assert_flag(.in_ref_col)+ # It may be a list |
||
| 116 | -12x | +209 | +401x |
- assert_valid_factor(x)+ if (checkmate::test_list(labels_in, null.ok = TRUE)) {
|
| 117 | -12x | +210 | +334x |
- assert_valid_factor(.ref_group)+ checkmate::assert_list(labels_in, null.ok = TRUE) |
| 118 | -12x | +|||
| 211 | +
- denom <- match.arg(denom)+ # Or it may be a vector of characters |
|||
| 119 | +212 |
-
+ } else {
|
||
| 120 | -12x | +213 | +67x |
- y <- s_summary.factor(+ checkmate::assert_character(labels_in, null.ok = TRUE) |
| 121 | -12x | +|||
| 214 | +
- x = x,+ } |
|||
| 122 | -12x | +|||
| 215 | +
- denom = denom,+ |
|||
| 123 | -12x | +216 | +401x |
- na.rm = na.rm,+ if (!is.null(row_nms)) {
|
| 124 | -+ | |||
| 217 | +43x |
- ...+ ret <- rep(row_nms, length(stats)) |
||
| 125 | -+ | |||
| 218 | +43x |
- )+ out <- setNames(ret, paste(rep(stats, each = length(row_nms)), ret, sep = ".")) |
||
| 126 | +219 | |||
| 127 | -12x | +220 | +43x |
- if (na.rm) {
+ if (!is.null(labels_in)) {
|
| 128 | -12x | +221 | +1x |
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ lvl_lbls <- intersect(names(labels_in), row_nms) |
| 129 | -12x | +222 | +1x |
- .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
+ for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- labels_in[[i]] |
| 130 | +223 |
- } else {
- |
- ||
| 131 | -! | -
- x <- x %>% explicit_na(label = "NA")- |
- ||
| 132 | -! | -
- .ref_group <- .ref_group %>% explicit_na(label = "NA")+ } |
||
| 133 | +224 |
- }+ } else {
+ |
+ ||
| 225 | +358x | +
+ which_lbl <- match(stats, names(tern_default_labels)) |
||
| 134 | +226 | |||
| 135 | -! | +|||
| 227 | +358x |
- if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
+ ret <- vector("character", length = length(stats)) # it needs to be a character vector
|
||
| 136 | -12x | +228 | +358x |
- checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)+ ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]] |
| 137 | +229 | |||
| 138 | -12x | +230 | +358x |
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ out <- setNames(ret, stats) |
| 139 | -9x | +|||
| 231 | +
- tab <- rbind(table(x), table(.ref_group))+ } |
|||
| 140 | -9x | +|||
| 232 | +
- res <- suppressWarnings(stats::chisq.test(tab))+ + |
+ |||
| 233 | ++ |
+ # Modify some with custom labels |
||
| 141 | -9x | +234 | +401x |
- res$p.value+ if (!is.null(labels_in)) {
|
| 142 | +235 |
- } else {
+ # Stats is the main |
||
| 143 | -3x | +236 | +67x |
- character()+ common_names <- intersect(names(out), names(labels_in))+ |
+
| 237 | +67x | +
+ out[common_names] <- labels_in[common_names] |
||
| 144 | +238 |
} |
||
| 145 | +239 | |||
| 146 | -12x | +240 | +401x |
- y+ out |
| 147 | +241 |
} |
||
| 148 | +242 | |||
| 149 | +243 |
- #' @describeIn compare_variables Method for `character` class. This makes an automatic+ #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics. |
||
| 150 | +244 |
- #' conversion to `factor` (with a warning) and then forwards to the method for factors.+ #' |
||
| 151 | +245 |
- #'+ #' @param indents_in (named `vector`)\cr inserted indent modifiers to replace defaults (default is `0L`). |
||
| 152 | +246 |
- #' @param verbose (`logical`)\cr Whether warnings and messages should be printed. Mainly used+ #' |
||
| 153 | +247 |
- #' to print out information about factor casting. Defaults to `TRUE`.+ #' @return |
||
| 154 | +248 |
- #'+ #' * `get_indents_from_stats()` returns a single indent modifier value to apply to all rows |
||
| 155 | +249 |
- #' @method s_compare character+ #' or a named numeric vector of indent modifiers (if present, otherwise `NULL`). |
||
| 156 | +250 |
#' |
||
| 157 | +251 |
#' @examples |
||
| 158 | +252 |
- #' # `s_compare.character`+ #' get_indents_from_stats(all_cnt_occ, indents_in = 3L) |
||
| 159 | +253 |
- #'+ #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L)) |
||
| 160 | +254 |
- #' ## Basic usage:+ #' get_indents_from_stats( |
||
| 161 | +255 |
- #' x <- c("a", "a", "b", "c", "a")
+ #' all_cnt_occ, |
||
| 162 | +256 |
- #' y <- c("a", "b", "c")
+ #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L), row_nms = c("a", "b")
|
||
| 163 | +257 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)+ #' ) |
||
| 164 | +258 |
#' |
||
| 165 | +259 |
- #' ## Note that missing values handling can make a large difference:+ #' @export |
||
| 166 | +260 |
- #' x <- c("a", "a", "b", "c", "a", NA)
+ get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
|
||
| 167 | -+ | |||
| 261 | +386x |
- #' y <- c("a", "b", "c", rep(NA, 20))
+ checkmate::assert_character(stats, min.len = 1) |
||
| 168 | -+ | |||
| 262 | +386x |
- #' s_compare(x,+ checkmate::assert_character(row_nms, null.ok = TRUE) |
||
| 169 | +263 |
- #' .ref_group = y, .in_ref_col = FALSE,+ # It may be a list |
||
| 170 | -+ | |||
| 264 | +386x |
- #' .var = "x", verbose = FALSE+ if (checkmate::test_list(indents_in, null.ok = TRUE)) {
|
||
| 171 | -+ | |||
| 265 | +337x |
- #' )+ checkmate::assert_list(indents_in, null.ok = TRUE) |
||
| 172 | +266 |
- #' s_compare(x,+ # Or it may be a vector of integers |
||
| 173 | +267 |
- #' .ref_group = y, .in_ref_col = FALSE, .var = "x",+ } else {
|
||
| 174 | -+ | |||
| 268 | +49x |
- #' na.rm = FALSE, verbose = FALSE+ checkmate::assert_integerish(indents_in, null.ok = TRUE) |
||
| 175 | +269 |
- #' )+ } |
||
| 176 | +270 |
- #'+ |
||
| 177 | -+ | |||
| 271 | +386x |
- #' @export+ if (is.null(names(indents_in)) && length(indents_in) == 1) {
|
||
| 178 | -+ | |||
| 272 | +8x |
- s_compare.character <- function(x,+ out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1) |
||
| 179 | -+ | |||
| 273 | +8x |
- .ref_group,+ return(out) |
||
| 180 | +274 |
- .in_ref_col,+ } |
||
| 181 | +275 |
- denom = "n",+ |
||
| 182 | -+ | |||
| 276 | +378x |
- na.rm = TRUE, # nolint+ if (!is.null(row_nms)) {
|
||
| 183 | -+ | |||
| 277 | +37x |
- .var,+ ret <- rep(0L, length(stats) * length(row_nms)) |
||
| 184 | -+ | |||
| 278 | +37x |
- verbose = TRUE,+ out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = ".")) |
||
| 185 | +279 |
- ...) {
+
|
||
| 186 | -1x | +280 | +37x |
- x <- as_factor_keep_attributes(x, verbose = verbose)+ if (!is.null(indents_in)) {
|
| 187 | +281 | 1x |
- .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose)+ lvl_lbls <- intersect(names(indents_in), row_nms) |
|
| 188 | +282 | 1x |
- s_compare(+ for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]] |
|
| 189 | -1x | +|||
| 283 | +
- x = x,+ } |
|||
| 190 | -1x | +|||
| 284 | +
- .ref_group = .ref_group,+ } else {
|
|||
| 191 | -1x | +285 | +341x |
- .in_ref_col = .in_ref_col,+ ret <- rep(0L, length(stats)) |
| 192 | -1x | +286 | +341x |
- denom = denom,+ out <- setNames(ret, stats) |
| 193 | -1x | +|||
| 287 | +
- na.rm = na.rm,+ } |
|||
| 194 | +288 |
- ...+ |
||
| 195 | +289 |
- )+ # Modify some with custom labels+ |
+ ||
| 290 | +378x | +
+ if (!is.null(indents_in)) {
|
||
| 196 | +291 |
- }+ # Stats is the main+ |
+ ||
| 292 | +42x | +
+ common_names <- intersect(names(out), names(indents_in))+ |
+ ||
| 293 | +42x | +
+ out[common_names] <- indents_in[common_names] |
||
| 197 | +294 | ++ |
+ }+ |
+ |
| 295 | ||||
| 296 | +378x | +
+ out+ |
+ ||
| 198 | +297 |
- #' @describeIn compare_variables Method for `logical` class. A chi-squared test+ } |
||
| 199 | +298 |
- #' is used. If missing values are not removed, then they are counted as `FALSE`.+ |
||
| 200 | +299 | ++ |
+ #' Update Labels According to Control Specifications+ |
+ |
| 300 |
#' |
|||
| 201 | +301 |
- #' @method s_compare logical+ #' @description `r lifecycle::badge("stable")`
|
||
| 202 | +302 |
#' |
||
| 203 | +303 |
- #' @examples+ #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant |
||
| 204 | +304 |
- #' # `s_compare.logical`+ #' control specification. For example, if control has element `conf_level` set to `0.9`, the default |
||
| 205 | +305 |
- #'+ #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied |
||
| 206 | +306 |
- #' ## Basic usage:+ #' via `labels_custom` will not be updated regardless of `control`. |
||
| 207 | +307 |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ #' |
||
| 208 | +308 |
- #' y <- c(FALSE, FALSE, TRUE)+ #' @param labels_default (named `vector` of `character`)\cr a named vector of statistic labels to modify |
||
| 209 | +309 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE)+ #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will |
||
| 210 | +310 |
- #'+ #' not be affected. |
||
| 211 | +311 |
- #' ## Management of NA values.+ #' @param labels_custom (named `vector` of `character`)\cr named vector of labels that are customized by |
||
| 212 | +312 |
- #' x <- c(NA, TRUE, FALSE)+ #' the user and should not be affected by `control`. |
||
| 213 | +313 |
- #' y <- c(NA, NA, NA, NA, FALSE)+ #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels. |
||
| 214 | +314 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ #' |
||
| 215 | +315 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ #' @return A named character vector of labels with control specifications applied to relevant labels. |
||
| 216 | +316 |
#' |
||
| 217 | +317 |
- #' @export+ #' @examples |
||
| 218 | +318 |
- s_compare.logical <- function(x,+ #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57) |
||
| 219 | +319 |
- .ref_group,+ #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
|
||
| 220 | +320 |
- .in_ref_col,+ #' labels_use_control(control = control) |
||
| 221 | +321 |
- na.rm = TRUE, # nolint+ #' |
||
| 222 | +322 |
- denom = "n",+ #' @export |
||
| 223 | +323 |
- ...) {
+ labels_use_control <- function(labels_default, control, labels_custom = NULL) {
|
||
| 224 | -3x | +324 | +14x |
- denom <- match.arg(denom)+ if ("conf_level" %in% names(control)) {
|
| 225 | -+ | |||
| 325 | +14x |
-
+ labels_default <- sapply( |
||
| 226 | -3x | +326 | +14x |
- y <- s_summary.logical(+ names(labels_default), |
| 227 | -3x | +327 | +14x |
- x = x,+ function(x) {
|
| 228 | -3x | +328 | +65x |
- na.rm = na.rm,+ if (!x %in% names(labels_custom)) {
|
| 229 | -3x | +329 | +64x |
- denom = denom,+ gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]])) |
| 230 | +330 |
- ...+ } else {
+ |
+ ||
| 331 | +1x | +
+ labels_default[[x]] |
||
| 231 | +332 |
- )+ } |
||
| 232 | +333 |
-
+ } |
||
| 233 | -3x | +|||
| 334 | +
- if (na.rm) {
+ ) |
|||
| 234 | -2x | +|||
| 335 | +
- x <- stats::na.omit(x)+ } |
|||
| 235 | -2x | +336 | +14x |
- .ref_group <- stats::na.omit(.ref_group)+ if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
|
| 236 | -+ | |||
| 337 | +14x |
- } else {
+ !"quantiles" %in% names(labels_custom)) { # nolint
|
||
| 237 | -1x | +338 | +14x |
- x[is.na(x)] <- FALSE+ labels_default["quantiles"] <- gsub( |
| 238 | -1x | +339 | +14x |
- .ref_group[is.na(.ref_group)] <- FALSE+ "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""), |
| 239 | -+ | |||
| 340 | +14x |
- }+ labels_default["quantiles"] |
||
| 240 | +341 |
-
+ ) |
||
| 241 | -3x | +|||
| 342 | +
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ } |
|||
| 242 | -3x | +343 | +14x |
- x <- factor(x, levels = c(TRUE, FALSE))+ if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
|
| 243 | -3x | +344 | +14x |
- .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))+ !"mean_pval" %in% names(labels_custom)) { # nolint
|
| 244 | -3x | +345 | +1x |
- tbl <- rbind(table(x), table(.ref_group))+ labels_default["mean_pval"] <- gsub( |
| 245 | -3x | +346 | +1x |
- suppressWarnings(prop_chisq(tbl))+ "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"] |
| 246 | +347 |
- } else {
- |
- ||
| 247 | -! | -
- character()+ ) |
||
| 248 | +348 |
} |
||
| 249 | +349 | |||
| 250 | -3x | +350 | +14x |
- y+ labels_default |
| 251 | +351 |
} |
||
| 252 | +352 | |||
| 253 | +353 |
- #' @describeIn compare_variables Formatted analysis function which is used as `afun`+ #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`. |
||
| 254 | +354 |
- #' in `compare_vars()`.+ #' |
||
| 255 | +355 |
- #'+ #' @format |
||
| 256 | +356 |
- #' @return+ #' * `tern_default_stats` is a named list of available statistics, with each element |
||
| 257 | +357 |
- #' * `a_compare()` returns the corresponding list with formatted [rtables::CellValue()].+ #' named for their corresponding statistical method group. |
||
| 258 | +358 |
#' |
||
| 259 | +359 |
- #' @note `a_compare()` has been deprecated in favor of `a_summary()` with argument `compare` set to `TRUE`.+ #' @export |
||
| 260 | +360 |
- #'+ tern_default_stats <- list( |
||
| 261 | +361 |
- #' @examples+ abnormal = c("fraction"),
|
||
| 262 | +362 |
- #' # `a_compare` deprecated - use `a_summary()` instead+ abnormal_by_baseline = c("fraction"),
|
||
| 263 | +363 |
- #' a_compare(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .stats = c("n", "pval"))
+ abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 264 | +364 |
- #'+ abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 265 | +365 |
- #' @export+ abnormal_by_worst_grade_worsen = c("fraction"),
|
||
| 266 | +366 |
- a_compare <- function(x,+ analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
|
||
| 267 | +367 |
- .N_col, # nolint+ analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 268 | +368 |
- .N_row, # nolint+ analyze_vars_numeric = c( |
||
| 269 | +369 |
- .var = NULL,+ "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval", |
||
| 270 | +370 |
- .df_row = NULL,+ "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv", |
||
| 271 | +371 |
- .ref_group = NULL,+ "geom_mean", "geom_mean_ci", "geom_cv" |
||
| 272 | +372 |
- .in_ref_col = FALSE,+ ), |
||
| 273 | +373 |
- ...) {
+ count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 274 | -1x | +|||
| 374 | +
- lifecycle::deprecate_warn(+ count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
|
|||
| 275 | -1x | +|||
| 375 | +
- "0.8.3",+ count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
|
|||
| 276 | -1x | +|||
| 376 | +
- "a_compare()",+ count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
|||
| 277 | -1x | +|||
| 377 | +
- details = "Please use a_summary() with argument `compare` set to TRUE instead."+ count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
|||
| 278 | +378 |
- )+ count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 279 | -1x | +|||
| 379 | +
- a_summary(+ count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
|||
| 280 | -1x | +|||
| 380 | +
- x = x,+ coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
|
|||
| 281 | -1x | +|||
| 381 | +
- .N_col = .N_col,+ estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci"),
|
|||
| 282 | -1x | +|||
| 382 | +
- .N_row = .N_row,+ estimate_multinomial_response = c("n_prop", "prop_ci"),
|
|||
| 283 | -1x | +|||
| 383 | +
- .var = .var,+ estimate_odds_ratio = c("or_ci", "n_tot"),
|
|||
| 284 | -1x | +|||
| 384 | +
- .df_row = .df_row,+ estimate_proportion = c("n_prop", "prop_ci"),
|
|||
| 285 | -1x | +|||
| 385 | +
- .ref_group = .ref_group,+ estimate_proportion_diff = c("diff", "diff_ci"),
|
|||
| 286 | -1x | +|||
| 386 | +
- .in_ref_col = .in_ref_col,+ summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
|
|||
| 287 | -1x | +|||
| 387 | +
- compare = TRUE,+ summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
|
|||
| 288 | +388 |
- ...+ summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 289 | +389 |
- )+ summarize_num_patients = c("unique", "nonunique", "unique_count"),
|
||
| 290 | +390 |
- }+ summarize_patients_events_in_cols = c("unique", "all"),
|
||
| 291 | +391 |
-
+ surv_time = c("median", "median_ci", "quantiles", "range_censor", "range_event", "range"),
|
||
| 292 | +392 |
- #' Constructor Function for [compare_vars()]+ surv_timepoint = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval"),
|
||
| 293 | +393 |
- #'+ tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
||
| 294 | +394 |
- #' @description `r lifecycle::badge("deprecated")`
+ tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
|
||
| 295 | +395 |
- #'+ tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 296 | +396 |
- #' Constructor function which creates a combined formatted analysis function.+ tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
|
||
| 297 | +397 |
- #'+ test_proportion_diff = c("pval")
|
||
| 298 | +398 |
- #' @inheritParams argument_convention+ ) |
||
| 299 | +399 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
||
| 300 | +400 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`. |
||
| 301 | +401 |
- #' for that statistic's row label.+ #' |
||
| 302 | +402 |
- #'+ #' @format |
||
| 303 | +403 |
- #' @return Combined formatted analysis function for use in [compare_vars()].+ #' * `tern_default_formats` is a named vector of available default formats, with each element |
||
| 304 | +404 | ++ |
+ #' named for their corresponding statistic.+ |
+ |
| 405 |
#' |
|||
| 305 | +406 |
- #' @note This function has been deprecated in favor of direct implementation of `a_summary()` with argument `compare`+ #' @export |
||
| 306 | +407 |
- #' set to `TRUE`.+ tern_default_formats <- c( |
||
| 307 | +408 |
- #'+ fraction = format_fraction_fixed_dp, |
||
| 308 | +409 |
- #' @seealso [compare_vars()]+ unique = format_count_fraction_fixed_dp, |
||
| 309 | +410 |
- #'+ nonunique = "xx", |
||
| 310 | +411 |
- #' @export+ unique_count = "xx", |
||
| 311 | +412 |
- create_afun_compare <- function(.stats = NULL,+ n = "xx.", |
||
| 312 | +413 |
- .formats = NULL,+ count = "xx.", |
||
| 313 | +414 |
- .labels = NULL,+ count_fraction = format_count_fraction, |
||
| 314 | +415 |
- .indent_mods = NULL) {
+ count_fraction_fixed_dp = format_count_fraction_fixed_dp, |
||
| 315 | -1x | +|||
| 416 | +
- lifecycle::deprecate_warn(+ n_blq = "xx.", |
|||
| 316 | -1x | +|||
| 417 | +
- "0.8.5.9010",+ sum = "xx.x", |
|||
| 317 | -1x | +|||
| 418 | +
- "create_afun_compare()",+ mean = "xx.x", |
|||
| 318 | -1x | +|||
| 419 | +
- details = "Please use a_summary(compare = TRUE) directly instead."+ sd = "xx.x", |
|||
| 319 | +420 |
- )+ se = "xx.x", |
||
| 320 | -1x | +|||
| 421 | +
- function(x,+ mean_sd = "xx.x (xx.x)", |
|||
| 321 | -1x | +|||
| 422 | +
- .ref_group,+ mean_se = "xx.x (xx.x)", |
|||
| 322 | -1x | +|||
| 423 | +
- .in_ref_col,+ mean_ci = "(xx.xx, xx.xx)", |
|||
| 323 | +424 |
- ...,+ mean_sei = "(xx.xx, xx.xx)", |
||
| 324 | -1x | +|||
| 425 | ++ |
+ mean_sdi = "(xx.xx, xx.xx)",+ |
+ ||
| 426 | +
- .var) {
+ mean_pval = "xx.xx", |
|||
| 325 | -! | +|||
| 427 | +
- a_summary(x,+ median = "xx.x", |
|||
| 326 | -! | +|||
| 428 | +
- compare = TRUE,+ mad = "xx.x", |
|||
| 327 | -! | +|||
| 429 | +
- .stats = .stats,+ median_ci = "(xx.xx, xx.xx)", |
|||
| 328 | -! | +|||
| 430 | +
- .formats = .formats,+ quantiles = "xx.x - xx.x", |
|||
| 329 | -! | +|||
| 431 | +
- .labels = .labels,+ iqr = "xx.x", |
|||
| 330 | -! | +|||
| 432 | +
- .indent_mods = .indent_mods,+ range = "xx.x - xx.x", |
|||
| 331 | -! | +|||
| 433 | +
- .ref_group = .ref_group,+ min = "xx.x", |
|||
| 332 | -! | +|||
| 434 | +
- .in_ref_col = .in_ref_col,+ max = "xx.x", |
|||
| 333 | -! | +|||
| 435 | +
- .var = .var, ...+ median_range = "xx.x (xx.x - xx.x)", |
|||
| 334 | +436 |
- )+ cv = "xx.x", |
||
| 335 | +437 |
- }+ geom_mean = "xx.x", |
||
| 336 | +438 |
- }+ geom_mean_ci = "(xx.xx, xx.xx)", |
||
| 337 | +439 |
-
+ geom_cv = "xx.x", |
||
| 338 | +440 |
- #' @describeIn compare_variables Layout-creating function which can take statistics function arguments+ pval = "x.xxxx | (<0.0001)", |
||
| 339 | +441 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ pval_counts = "x.xxxx | (<0.0001)", |
||
| 340 | +442 |
- #'+ range_censor = "xx.x to xx.x", |
||
| 341 | +443 |
- #' @param ... arguments passed to `s_compare()`.+ range_event = "xx.x to xx.x" |
||
| 342 | +444 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ ) |
||
| 343 | +445 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
||
| 344 | +446 |
- #' for that statistic's row label.+ #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`. |
||
| 345 | +447 |
#' |
||
| 346 | +448 |
- #' @return+ #' @format |
||
| 347 | +449 |
- #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions,+ #' * `tern_default_labels` is a named `character` vector of available default labels, with each element |
||
| 348 | +450 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' named for their corresponding statistic. |
||
| 349 | +451 |
- #' the statistics from `s_compare()` to the table layout.+ #' |
||
| 350 | +452 |
- #'+ #' @export |
||
| 351 | +453 |
- #' @examples+ tern_default_labels <- c( |
||
| 352 | +454 |
- #' # `compare_vars()` in `rtables` pipelines+ fraction = "fraction", |
||
| 353 | +455 |
- #'+ unique = "Number of patients with at least one event", |
||
| 354 | +456 |
- #' ## Default output within a `rtables` pipeline.+ nonunique = "Number of events", |
||
| 355 | +457 |
- #' lyt <- basic_table() %>%+ n = "n", |
||
| 356 | +458 |
- #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
+ count = "count", |
||
| 357 | +459 |
- #' compare_vars(c("AGE", "SEX"))
+ count_fraction = "count_fraction", |
||
| 358 | +460 |
- #' build_table(lyt, tern_ex_adsl)+ count_fraction_fixed_dp = "count_fraction", |
||
| 359 | +461 |
- #'+ n_blq = "n_blq", |
||
| 360 | +462 |
- #' ## Select and format statistics output.+ sum = "Sum", |
||
| 361 | +463 |
- #' lyt <- basic_table() %>%+ mean = "Mean", |
||
| 362 | +464 |
- #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
+ sd = "SD", |
||
| 363 | +465 |
- #' compare_vars(+ se = "SE", |
||
| 364 | +466 |
- #' vars = "AGE",+ mean_sd = "Mean (SD)", |
||
| 365 | +467 |
- #' .stats = c("mean_sd", "pval"),
+ mean_se = "Mean (SE)", |
||
| 366 | +468 |
- #' .formats = c(mean_sd = "xx.x, xx.x"),+ mean_ci = "Mean 95% CI", |
||
| 367 | +469 |
- #' .labels = c(mean_sd = "Mean, SD")+ mean_sei = "Mean -/+ 1xSE", |
||
| 368 | +470 |
- #' )+ mean_sdi = "Mean -/+ 1xSD", |
||
| 369 | +471 |
- #' build_table(lyt, df = tern_ex_adsl)+ mean_pval = "Mean p-value (H0: mean = 0)", |
||
| 370 | +472 |
- #'+ median = "Median", |
||
| 371 | +473 |
- #' @export+ mad = "Median Absolute Deviation", |
||
| 372 | +474 |
- #' @order 2+ median_ci = "Median 95% CI", |
||
| 373 | +475 |
- compare_vars <- function(lyt,+ quantiles = "25% and 75%-ile", |
||
| 374 | +476 |
- vars,+ iqr = "IQR", |
||
| 375 | +477 |
- var_labels = vars,+ range = "Min - Max", |
||
| 376 | +478 |
- na_level = lifecycle::deprecated(),+ min = "Minimum", |
||
| 377 | +479 |
- na_str = default_na_str(),+ max = "Maximum", |
||
| 378 | +480 |
- nested = TRUE,+ median_range = "Median (Min - Max)", |
||
| 379 | +481 |
- ...,+ cv = "CV (%)", |
||
| 380 | +482 |
- na.rm = TRUE, # nolint+ geom_mean = "Geometric Mean", |
||
| 381 | +483 |
- show_labels = "default",+ geom_mean_ci = "Geometric Mean 95% CI", |
||
| 382 | +484 |
- table_names = vars,+ geom_cv = "CV % Geometric Mean", |
||
| 383 | +485 |
- section_div = NA_character_,+ pval = "p-value (t-test)", # Default for numeric |
||
| 384 | +486 |
- .stats = c("n", "mean_sd", "count_fraction", "pval"),
+ pval_counts = "p-value (chi-squared test)" # Default for counts |
||
| 385 | +487 |
- .formats = NULL,+ ) |
||
| 386 | +488 |
- .labels = NULL,+ |
||
| 387 | +489 |
- .indent_mods = NULL) {
+ # To deprecate --------- |
||
| 388 | -4x | +|||
| 490 | +
- if (lifecycle::is_present(na_level)) {
+
|
|||
| 389 | -! | +|||
| 491 | +
- lifecycle::deprecate_warn("0.9.1", "compare_vars(na_level)", "compare_vars(na_str)")
+ #' @describeIn default_stats_formats_labels Quick function to retrieve default formats for summary statistics: |
|||
| 390 | -! | +|||
| 492 | +
- na_str <- na_level+ #' [analyze_vars()] and [analyze_vars_in_cols()] principally. |
|||
| 391 | +493 |
- }+ #' |
||
| 392 | +494 |
-
+ #' @param type (`flag`)\cr is it going to be `"numeric"` or `"counts"`? |
||
| 393 | -4x | +|||
| 495 | +
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...)+ #' |
|||
| 394 | -1x | +|||
| 496 | +
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ #' @return |
|||
| 395 | -1x | +|||
| 497 | +
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type. |
|||
| 396 | -! | +|||
| 498 | +
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ #' |
|||
| 397 | +499 |
-
+ #' @examples |
||
| 398 | -4x | +|||
| 500 | +
- analyze(+ #' summary_formats() |
|||
| 399 | -4x | +|||
| 501 | +
- lyt = lyt,+ #' summary_formats(type = "counts", include_pval = TRUE) |
|||
| 400 | -4x | +|||
| 502 | +
- vars = vars,+ #' |
|||
| 401 | -4x | +|||
| 503 | +
- var_labels = var_labels,+ #' @export |
|||
| 402 | -4x | +|||
| 504 | +
- afun = a_summary,+ summary_formats <- function(type = "numeric", include_pval = FALSE) {
|
|||
| 403 | -4x | +505 | +3x |
- na_str = na_str,+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 404 | -4x | +506 | +3x |
- nested = nested,+ get_formats_from_stats(get_stats(met_grp, add_pval = include_pval)) |
| 405 | -4x | +|||
| 507 | +
- extra_args = extra_args,+ } |
|||
| 406 | -4x | +|||
| 508 | +
- inclNAs = TRUE,+ |
|||
| 407 | -4x | +|||
| 509 | +
- show_labels = show_labels,+ #' @describeIn default_stats_formats_labels Quick function to retrieve default labels for summary statistics. |
|||
| 408 | -4x | +|||
| 510 | +
- table_names = table_names,+ #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats` |
|||
| 409 | -4x | +|||
| 511 | +
- section_div = section_div+ #' |
|||
| 410 | +512 |
- )+ #' @param include_pval (`flag`)\cr deprecated parameter. Same as `add_pval`. |
||
| 411 | +513 |
- }+ #' @return |
| 1 | +514 |
- #' Helper Function for Deriving Analysis Datasets for `LBT13` and `LBT14`+ #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type. |
||
| 2 | +515 |
#' |
||
| 3 | +516 |
- #' @description `r lifecycle::badge("stable")`
+ #' @examples |
||
| 4 | +517 |
- #'+ #' summary_labels() |
||
| 5 | +518 |
- #' Helper function that merges `ADSL` and `ADLB` datasets so that missing lab test records are inserted in the+ #' summary_labels(type = "counts", include_pval = TRUE) |
||
| 6 | +519 |
- #' output dataset. Remember that `na_level` must match the needed pre-processing+ #' |
||
| 7 | +520 |
- #' done with [df_explicit_na()] to have the desired output.+ #' @export |
||
| 8 | +521 |
- #'+ summary_labels <- function(type = "numeric", include_pval = FALSE) {
+ |
+ ||
| 522 | +3x | +
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+ ||
| 523 | +3x | +
+ get_labels_from_stats(get_stats(met_grp, add_pval = include_pval)) |
||
| 9 | +524 |
- #' @param adsl (`data.frame`)\cr `ADSL` dataframe.+ } |
||
| 10 | +525 |
- #' @param adlb (`data.frame`)\cr `ADLB` dataframe.+ |
||
| 11 | +526 |
- #' @param worst_flag (named `vector`)\cr Worst post-baseline lab flag variable.+ #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")` Function to
|
||
| 12 | +527 |
- #' @param by_visit (`logical`)\cr defaults to `FALSE` to generate worst grade per patient.+ #' configure settings for default or custom summary statistics for a given data type. In |
||
| 13 | +528 |
- #' If worst grade per patient per visit is specified for `worst_flag`, then+ #' addition to selecting a custom subset of statistics, the user can also set custom |
||
| 14 | +529 |
- #' `by_visit` should be `TRUE` to generate worst grade patient per visit.+ #' formats, labels, and indent modifiers for any of these statistics. |
||
| 15 | +530 |
- #' @param no_fillin_visits (named `character`)\cr Visits that are not considered for post-baseline worst toxicity+ #' |
||
| 16 | +531 |
- #' grade. Defaults to `c("SCREENING", "BASELINE")`.
+ #' @param stats_custom (`named vector` of `character`)\cr vector of statistics to include if |
||
| 17 | +532 |
- #'+ #' not the defaults. This argument overrides `include_pval` and other custom value arguments |
||
| 18 | +533 |
- #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`,+ #' such that only settings for these statistics will be returned. |
||
| 19 | +534 |
- #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when+ #' @param formats_custom (`named vector` of `character`)\cr vector of custom statistics formats |
||
| 20 | +535 |
- #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
+ #' to use in place of the defaults defined in [`summary_formats()`]. Names should be a subset |
||
| 21 | +536 |
- #'+ #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`). |
||
| 22 | +537 |
- #' @details In the result data missing records will be created for the following situations:+ #' @param labels_custom (`named vector` of `character`)\cr vector of custom statistics labels |
||
| 23 | +538 |
- #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline).+ #' to use in place of the defaults defined in [`summary_labels()`]. Names should be a subset |
||
| 24 | +539 |
- #' * Patients who do not have any post-baseline lab values.+ #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`). |
||
| 25 | +540 |
- #' * Patients without any post-baseline values flagged as the worst.+ #' @param indent_mods_custom (`integer` or `named vector` of `integer`)\cr vector of custom |
||
| 26 | +541 |
- #'+ #' indentation modifiers for statistics to use instead of the default of `0L` for all statistics. |
||
| 27 | +542 |
- #' @examples+ #' Names should be a subset of the statistics defined in `stats_custom` (or default statistics |
||
| 28 | +543 |
- #' # `h_adsl_adlb_merge_using_worst_flag`+ #' if this is `NULL`). Alternatively, the same indentation modifier can be applied to all |
||
| 29 | +544 |
- #' adlb_out <- h_adsl_adlb_merge_using_worst_flag(+ #' statistics by setting `indent_mods_custom` to a single integer value. |
||
| 30 | +545 |
- #' tern_ex_adsl,+ #' |
||
| 31 | +546 |
- #' tern_ex_adlb,+ #' @return |
||
| 32 | +547 |
- #' worst_flag = c("WGRHIFL" = "Y")
+ #' * `summary_custom` returns a `list` of 4 named elements: `stats`, `formats`, `labels`, |
||
| 33 | +548 |
- #' )+ #' and `indent_mods`. |
||
| 34 | +549 |
#' |
||
| 35 | +550 |
- #' # `h_adsl_adlb_merge_using_worst_flag` by visit example+ #' @examples |
||
| 36 | +551 |
- #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag(+ #' summary_custom() |
||
| 37 | +552 |
- #' tern_ex_adsl,+ #' summary_custom(type = "counts", include_pval = TRUE) |
||
| 38 | +553 |
- #' tern_ex_adlb,+ #' summary_custom( |
||
| 39 | +554 |
- #' worst_flag = c("WGRLOVFL" = "Y"),
+ #' include_pval = TRUE, stats_custom = c("n", "mean", "sd", "pval"),
|
||
| 40 | +555 |
- #' by_visit = TRUE+ #' labels_custom = c(sd = "Std. Dev."), indent_mods_custom = 3L |
||
| 41 | +556 |
#' ) |
||
| 42 | +557 |
#' |
||
| 43 | +558 |
#' @export |
||
| 44 | +559 |
- h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint+ summary_custom <- function(type = "numeric", |
||
| 45 | +560 |
- adlb,+ include_pval = FALSE, |
||
| 46 | +561 |
- worst_flag = c("WGRHIFL" = "Y"),
+ stats_custom = NULL, |
||
| 47 | +562 |
- by_visit = FALSE,+ formats_custom = NULL, |
||
| 48 | +563 |
- no_fillin_visits = c("SCREENING", "BASELINE")) {
+ labels_custom = NULL,+ |
+ ||
| 564 | ++ |
+ indent_mods_custom = NULL) {
|
||
| 49 | -5x | +565 | +1x |
- col_names <- names(worst_flag)+ lifecycle::deprecate_warn( |
| 50 | -5x | +566 | +1x |
- filter_values <- worst_flag+ "0.9.0.9001",+ |
+
| 567 | +1x | +
+ "summary_custom()",+ |
+ ||
| 568 | +1x | +
+ details = "Please use `get_stats`, `get_formats_from_stats`, and `get_labels_from_stats` directly instead." |
||
| 51 | +569 |
-
+ ) |
||
| 52 | -5x | +570 | +1x |
- temp <- Map(+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 53 | -5x | +571 | +1x |
- function(x, y) which(adlb[[x]] == y),+ .stats <- get_stats(met_grp, stats_custom, add_pval = include_pval) |
| 54 | -5x | +572 | +1x |
- col_names,+ .formats <- get_formats_from_stats(.stats, formats_custom) |
| 55 | -5x | +573 | +1x |
- filter_values+ .labels <- get_labels_from_stats(.stats, labels_custom) |
| 56 | -+ | |||
| 574 | +1x |
- )+ .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats) |
||
| 57 | +575 | |||
| 58 | -5x | +576 | +1x |
- position_satisfy_filters <- Reduce(intersect, temp)+ if (!is.null(indent_mods_custom)) {
+ |
+
| 577 | +! | +
+ if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
+ |
+ ||
| 578 | +! | +
+ .indent_mods[names(.indent_mods)] <- indent_mods_custom |
||
| 59 | +579 |
-
+ } else {
|
||
| 60 | -5x | +|||
| 580 | +! |
- adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb))+ .indent_mods[names(indent_mods_custom)] <- indent_mods_custom |
||
| 61 | -5x | +|||
| 581 | +
- columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
+ } |
|||
| 62 | +582 | ++ |
+ }+ |
+ |
| 583 | ||||
| 63 | -5x | +584 | +1x |
- adlb_f <- adlb[position_satisfy_filters, ] %>%+ list( |
| 64 | -5x | +585 | +1x |
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits)+ stats = .stats, |
| 65 | -5x | +586 | +1x |
- adlb_f <- adlb_f[, columns_from_adlb]+ formats = .formats,+ |
+
| 587 | +1x | +
+ labels = .labels,+ |
+ ||
| 588 | +1x | +
+ indent_mods = .indent_mods[.stats] |
||
| 66 | +589 |
-
+ ) |
||
| 67 | -5x | +|||
| 590 | +
- avisits_grid <- adlb %>%+ } |
|||
| 68 | -5x | +
| 1 | +
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>%+ #' Combine Factor Levels |
|||
| 69 | -5x | +|||
| 2 | +
- dplyr::pull(.data[["AVISIT"]]) %>%+ #' |
|||
| 70 | -5x | +|||
| 3 | +
- unique()+ #' @description `r lifecycle::badge("stable")`
|
|||
| 71 | +4 |
-
+ #' |
||
| 72 | -5x | +|||
| 5 | +
- if (by_visit) {
+ #' Combine specified old factor Levels in a single new level. |
|||
| 73 | -1x | +|||
| 6 | +
- adsl_lb <- expand.grid(+ #' |
|||
| 74 | -1x | +|||
| 7 | +
- USUBJID = unique(adsl$USUBJID),+ #' @param x factor |
|||
| 75 | -1x | +|||
| 8 | +
- AVISIT = avisits_grid,+ #' @param levels level names to be combined |
|||
| 76 | -1x | +|||
| 9 | +
- PARAMCD = unique(adlb$PARAMCD)+ #' @param new_level name of new level |
|||
| 77 | +10 |
- )+ #' |
||
| 78 | +11 |
-
+ #' @return A `factor` with the new levels. |
||
| 79 | -1x | +|||
| 12 | +
- adsl_lb <- adsl_lb %>%+ #' |
|||
| 80 | -1x | +|||
| 13 | +
- dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
+ #' @examples |
|||
| 81 | -1x | +|||
| 14 | +
- dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ #' x <- factor(letters[1:5], levels = letters[5:1]) |
|||
| 82 | +15 |
-
+ #' combine_levels(x, levels = c("a", "b"))
|
||
| 83 | -1x | +|||
| 16 | +
- adsl1 <- adsl[, adsl_adlb_common_columns]+ #' |
|||
| 84 | -1x | +|||
| 17 | +
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ #' combine_levels(x, c("e", "b"))
|
|||
| 85 | +18 |
-
+ #' |
||
| 86 | -1x | +|||
| 19 | +
- by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
+ #' @export |
|||
| 87 | +20 |
-
+ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
|
||
| 88 | -1x | +21 | +4x |
- adlb_btoxgr <- adlb %>%+ checkmate::assert_factor(x) |
| 89 | -1x | +22 | +4x |
- dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
+ checkmate::assert_subset(levels, levels(x)) |
| 90 | -1x | +|||
| 23 | +
- unique() %>%+ |
|||
| 91 | -1x | +24 | +4x |
- dplyr::rename("BTOXGR_MAP" = "BTOXGR")
+ lvls <- levels(x) |
| 92 | +25 | |||
| 93 | -1x | +26 | +4x |
- adlb_out <- merge(+ lvls[lvls %in% levels] <- new_level |
| 94 | -1x | +|||
| 27 | +
- adlb_f,+ |
|||
| 95 | -1x | +28 | +4x |
- adsl_lb,+ levels(x) <- lvls |
| 96 | -1x | +|||
| 29 | +
- by = by_variables_from_adlb,+ |
|||
| 97 | -1x | +30 | +4x |
- all = TRUE,+ x |
| 98 | -1x | +|||
| 31 | +
- sort = FALSE+ } |
|||
| 99 | +32 |
- )+ |
||
| 100 | -1x | +|||
| 33 | +
- adlb_out <- adlb_out %>%+ #' Conversion of a Vector to a Factor |
|||
| 101 | -1x | +|||
| 34 | +
- dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+ #' |
|||
| 102 | -1x | +|||
| 35 | +
- dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user |
|||
| 103 | -1x | +|||
| 36 | +
- dplyr::select(-"BTOXGR_MAP")+ #' can decide whether they prefer converting to factor manually (e.g. for full control of |
|||
| 104 | +37 |
-
+ #' factor levels). |
||
| 105 | -1x | +|||
| 38 | +
- adlb_var_labels <- c(+ #' |
|||
| 106 | -1x | +|||
| 39 | +
- formatters::var_labels(adlb[by_variables_from_adlb]),+ #' @param x (`atomic`)\cr object to convert. |
|||
| 107 | -1x | +|||
| 40 | +
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ #' @param x_name (`string`)\cr name of `x`. |
|||
| 108 | -1x | +|||
| 41 | +
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector. |
|||
| 109 | +42 |
- )+ #' @param verbose defaults to `TRUE`. It prints out warnings and messages. |
||
| 110 | +43 |
- } else {
+ #' |
||
| 111 | -4x | +|||
| 44 | +
- adsl_lb <- expand.grid(+ #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. |
|||
| 112 | -4x | +|||
| 45 | +
- USUBJID = unique(adsl$USUBJID),+ #' |
|||
| 113 | -4x | +|||
| 46 | +
- PARAMCD = unique(adlb$PARAMCD)+ #' @keywords internal |
|||
| 114 | +47 |
- )+ as_factor_keep_attributes <- function(x, |
||
| 115 | +48 |
-
+ x_name = deparse(substitute(x)), |
||
| 116 | -4x | +|||
| 49 | +
- adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ na_level = "<Missing>", |
|||
| 117 | +50 |
-
+ verbose = TRUE) {
|
||
| 118 | -4x | +51 | +168x |
- adsl1 <- adsl[, adsl_adlb_common_columns]+ checkmate::assert_atomic(x) |
| 119 | -4x | +52 | +168x |
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ checkmate::assert_string(x_name) |
| 120 | -+ | |||
| 53 | +168x |
-
+ checkmate::assert_string(na_level) |
||
| 121 | -4x | +54 | +168x |
- by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
+ checkmate::assert_flag(verbose) |
| 122 | -+ | |||
| 55 | +168x |
-
+ if (is.factor(x)) {
|
||
| 123 | -4x | +56 | +153x |
- adlb_out <- merge(+ return(x) |
| 124 | -4x | +|||
| 57 | +
- adlb_f,+ } |
|||
| 125 | -4x | +58 | +15x |
- adsl_lb,+ x_class <- class(x)[1] |
| 126 | -4x | +59 | +15x |
- by = by_variables_from_adlb,+ if (verbose) {
|
| 127 | -4x | +60 | +15x |
- all = TRUE,+ warning(paste( |
| 128 | -4x | +61 | +15x |
- sort = FALSE+ "automatically converting", x_class, "variable", x_name, |
| 129 | -+ | |||
| 62 | +15x |
- )+ "to factor, better manually convert to factor to avoid failures" |
||
| 130 | +63 |
-
+ )) |
||
| 131 | -4x | +|||
| 64 | +
- adlb_var_labels <- c(+ } |
|||
| 132 | -4x | +65 | +15x |
- formatters::var_labels(adlb[by_variables_from_adlb]),+ if (identical(length(x), 0L)) {
|
| 133 | -4x | +66 | +1x |
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ warning(paste( |
| 134 | -4x | +67 | +1x |
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ x_name, "has length 0, this can lead to tabulation failures, better convert to factor" |
| 135 | +68 |
- )+ )) |
||
| 136 | +69 |
} |
||
| 137 | -+ | |||
| 70 | +15x |
-
+ if (is.character(x)) {
|
||
| 138 | -5x | +71 | +15x |
- adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ x_no_na <- explicit_na(sas_na(x), label = na_level) |
| 139 | -5x | +72 | +15x |
- adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ if (any(na_level %in% x_no_na)) {
|
| 140 | -+ | |||
| 73 | +3x |
-
+ do.call( |
||
| 141 | -5x | +74 | +3x |
- formatters::var_labels(adlb_out) <- adlb_var_labels+ structure, |
| 142 | -+ | |||
| 75 | +3x |
-
+ c( |
||
| 143 | -5x | +76 | +3x |
- adlb_out+ list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)), |
| 144 | -+ | |||
| 77 | +3x |
- }+ attributes(x) |
| 1 | +78 |
- #' Proportion Difference+ ) |
||
| 2 | +79 |
- #'+ ) |
||
| 3 | +80 |
- #' @description `r lifecycle::badge("stable")`
+ } else {
|
||
| 4 | -+ | |||
| 81 | +12x |
- #'+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
||
| 5 | +82 |
- #' @inheritParams prop_diff_strat_nc+ } |
||
| 6 | +83 |
- #' @inheritParams argument_convention+ } else {
|
||
| 7 | -+ | |||
| 84 | +! |
- #' @param method (`string`)\cr the method used for the confidence interval estimation.+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
||
| 8 | +85 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion_diff")`
+ } |
||
| 9 | +86 |
- #' to see available statistics for this function.+ } |
||
| 10 | +87 |
- #'+ |
||
| 11 | +88 |
- #' @seealso [d_proportion_diff()]+ #' Labels for Bins in Percent |
||
| 12 | +89 |
#' |
||
| 13 | +90 |
- #' @name prop_diff+ #' This creates labels for quantile based bins in percent. This assumes the right-closed |
||
| 14 | +91 |
- #' @order 1+ #' intervals as produced by [cut_quantile_bins()]. |
||
| 15 | +92 |
- NULL+ #' |
||
| 16 | +93 |
-
+ #' @param probs (`proportion` vector)\cr the probabilities identifying the quantiles. |
||
| 17 | +94 |
- #' @describeIn prop_diff Statistics function estimating the difference+ #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where |
||
| 18 | +95 |
- #' in terms of responder proportion.+ #' the boundaries 0 and 1 must not be included. |
||
| 19 | +96 |
- #'+ #' @param digits (`integer`)\cr number of decimal places to round the percent numbers. |
||
| 20 | +97 |
- #' @return+ #' |
||
| 21 | +98 |
- #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`.+ #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc. |
||
| 22 | +99 |
#' |
||
| 23 | +100 |
- #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are+ #' @keywords internal |
||
| 24 | +101 |
- #' not permitted.+ bins_percent_labels <- function(probs, |
||
| 25 | +102 |
- #'+ digits = 0) {
|
||
| 26 | -+ | |||
| 103 | +1x |
- #' @examples+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
||
| 27 | -+ | |||
| 104 | +1x |
- #' s_proportion_diff(+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
||
| 28 | -+ | |||
| 105 | +8x |
- #' df = subset(dta, grp == "A"),+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
||
| 29 | -+ | |||
| 106 | +8x |
- #' .var = "rsp",+ percent <- round(probs * 100, digits = digits) |
||
| 30 | -+ | |||
| 107 | +8x |
- #' .ref_group = subset(dta, grp == "B"),+ left <- paste0(utils::head(percent, -1), "%") |
||
| 31 | -+ | |||
| 108 | +8x |
- #' .in_ref_col = FALSE,+ right <- paste0(utils::tail(percent, -1), "%")+ |
+ ||
| 109 | +8x | +
+ without_left_bracket <- paste0(left, ",", right, "]")+ |
+ ||
| 110 | +8x | +
+ with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
+ |
+ ||
| 111 | +8x | +
+ if (length(without_left_bracket) > 1) {
+ |
+ ||
| 112 | +6x | +
+ with_left_bracket <- c(+ |
+ ||
| 113 | +6x | +
+ with_left_bracket,+ |
+ ||
| 114 | +6x | +
+ paste0("(", utils::tail(without_left_bracket, -1))
|
||
| 32 | +115 |
- #' conf_level = 0.90,+ ) |
||
| 33 | +116 |
- #' method = "ha"+ }+ |
+ ||
| 117 | +8x | +
+ with_left_bracket |
||
| 34 | +118 |
- #' )+ } |
||
| 35 | +119 |
- #'+ |
||
| 36 | +120 |
- #' # CMH example with strata+ #' Cutting Numeric Vector into Empirical Quantile Bins |
||
| 37 | +121 |
- #' s_proportion_diff(+ #' |
||
| 38 | +122 |
- #' df = subset(dta, grp == "A"),+ #' @description `r lifecycle::badge("stable")`
|
||
| 39 | +123 |
- #' .var = "rsp",+ #' |
||
| 40 | +124 |
- #' .ref_group = subset(dta, grp == "B"),+ #' This cuts a numeric vector into sample quantile bins. |
||
| 41 | +125 |
- #' .in_ref_col = FALSE,+ #' |
||
| 42 | +126 |
- #' variables = list(strata = c("f1", "f2")),
+ #' @inheritParams bins_percent_labels |
||
| 43 | +127 |
- #' conf_level = 0.90,+ #' @param x (`numeric`)\cr the continuous variable values which should be cut into |
||
| 44 | +128 |
- #' method = "cmh"+ #' quantile bins. This may contain `NA` values, which are then |
||
| 45 | +129 |
- #' )+ #' not used for the quantile calculations, but included in the return vector. |
||
| 46 | +130 |
- #'+ #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n` |
||
| 47 | +131 |
- #' @export+ #' probabilities in `probs`, then this must be `n + 1` long. |
||
| 48 | +132 |
- s_proportion_diff <- function(df,+ #' @param type (`integer`)\cr type of quantiles to use, see [stats::quantile()] for details. |
||
| 49 | +133 |
- .var,+ #' @param ordered (`flag`)\cr should the result be an ordered factor. |
||
| 50 | +134 |
- .ref_group,+ #' |
||
| 51 | +135 |
- .in_ref_col,+ #' @return A `factor` variable with appropriately-labeled bins as levels. |
||
| 52 | +136 |
- variables = list(strata = NULL),+ #' |
||
| 53 | +137 |
- conf_level = 0.95,+ #' @note Intervals are closed on the right side. That is, the first bin is the interval |
||
| 54 | +138 |
- method = c(+ #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc., |
||
| 55 | +139 |
- "waldcc", "wald", "cmh",+ #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile. |
||
| 56 | +140 |
- "ha", "newcombe", "newcombecc",+ #' |
||
| 57 | +141 |
- "strat_newcombe", "strat_newcombecc"+ #' @examples |
||
| 58 | +142 |
- ),+ #' # Default is to cut into quartile bins. |
||
| 59 | +143 |
- weights_method = "cmh") {
+ #' cut_quantile_bins(cars$speed) |
||
| 60 | -2x | +|||
| 144 | +
- method <- match.arg(method)+ #' |
|||
| 61 | -2x | +|||
| 145 | +
- if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
+ #' # Use custom quantiles. |
|||
| 62 | -! | +|||
| 146 | +
- stop(paste(+ #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88)) |
|||
| 63 | -! | +|||
| 147 | +
- "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",+ #' |
|||
| 64 | -! | +|||
| 148 | +
- "permitted. Please choose a different method."+ #' # Use custom labels. |
|||
| 65 | +149 |
- ))+ #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
|
||
| 66 | +150 |
- }+ #' |
||
| 67 | -2x | +|||
| 151 | +
- y <- list(diff = "", diff_ci = "")+ #' # NAs are preserved in result factor. |
|||
| 68 | +152 |
-
+ #' ozone_binned <- cut_quantile_bins(airquality$Ozone) |
||
| 69 | -2x | +|||
| 153 | +
- if (!.in_ref_col) {
+ #' which(is.na(ozone_binned)) |
|||
| 70 | -2x | +|||
| 154 | +
- rsp <- c(.ref_group[[.var]], df[[.var]])+ #' # So you might want to make these explicit. |
|||
| 71 | -2x | +|||
| 155 | +
- grp <- factor(+ #' explicit_na(ozone_binned) |
|||
| 72 | -2x | +|||
| 156 | +
- rep(+ #' |
|||
| 73 | -2x | +|||
| 157 | +
- c("ref", "Not-ref"),
+ #' @export |
|||
| 74 | -2x | +|||
| 158 | +
- c(nrow(.ref_group), nrow(df))+ cut_quantile_bins <- function(x, |
|||
| 75 | +159 |
- ),+ probs = c(0.25, 0.5, 0.75), |
||
| 76 | -2x | +|||
| 160 | +
- levels = c("ref", "Not-ref")
+ labels = NULL, |
|||
| 77 | +161 |
- )+ type = 7, |
||
| 78 | +162 |
-
+ ordered = TRUE) {
|
||
| 79 | -2x | +163 | +8x |
- if (!is.null(variables$strata)) {
+ checkmate::assert_flag(ordered) |
| 80 | -1x | +164 | +8x |
- strata_colnames <- variables$strata+ checkmate::assert_numeric(x) |
| 81 | -1x | +165 | +7x |
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 82 | -1x | +166 | +7x |
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 83 | -+ | |||
| 167 | +8x |
-
+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
||
| 84 | -1x | +168 | +7x |
- assert_df_with_variables(df, strata_vars)+ if (is.null(labels)) labels <- bins_percent_labels(probs) |
| 85 | -1x | +169 | +8x |
- assert_df_with_variables(.ref_group, strata_vars)+ checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE) |
| 86 | +170 | |||
| 87 | -- |
- # Merging interaction strata for reference group rows data and remaining- |
- ||
| 88 | -1x | -
- strata <- c(- |
- ||
| 89 | -1x | -
- interaction(.ref_group[strata_colnames]),- |
- ||
| 90 | -1x | +171 | +8x |
- interaction(df[strata_colnames])+ if (all(is.na(x))) {
|
| 91 | +172 |
- )+ # Early return if there are only NAs in input. |
||
| 92 | +173 | 1x |
- strata <- as.factor(strata)+ return(factor(x, ordered = ordered, levels = labels)) |
|
| 93 | +174 |
- }+ } |
||
| 94 | +175 | |||
| 95 | -+ | |||
| 176 | +7x |
- # Defining the std way to calculate weights for strat_newcombe+ quantiles <- stats::quantile( |
||
| 96 | -2x | +177 | +7x |
- if (!is.null(variables$weights_method)) {
+ x, |
| 97 | -! | +|||
| 178 | +7x |
- weights_method <- variables$weights_method+ probs = probs, |
||
| 98 | -+ | |||
| 179 | +7x |
- } else {
+ type = type, |
||
| 99 | -2x | +180 | +7x |
- weights_method <- "cmh"+ na.rm = TRUE |
| 100 | +181 |
- }+ ) |
||
| 101 | +182 | |||
| 102 | -2x | +183 | +7x |
- y <- switch(method,+ checkmate::assert_numeric(quantiles, unique = TRUE) |
| 103 | -2x | +|||
| 184 | +
- "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),+ |
|||
| 104 | -2x | +185 | +6x |
- "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),+ cut( |
| 105 | -2x | +186 | +6x |
- "ha" = prop_diff_ha(rsp, grp, conf_level),+ x, |
| 106 | -2x | +187 | +6x |
- "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),+ breaks = quantiles, |
| 107 | -2x | +188 | +6x |
- "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),+ labels = labels, |
| 108 | -2x | +189 | +6x |
- "strat_newcombe" = prop_diff_strat_nc(rsp,+ ordered_result = ordered, |
| 109 | -2x | +190 | +6x |
- grp,+ include.lowest = TRUE, |
| 110 | -2x | +191 | +6x |
- strata,+ right = TRUE |
| 111 | -2x | +|||
| 192 | +
- weights_method,+ ) |
|||
| 112 | -2x | +|||
| 193 | +
- conf_level,+ } |
|||
| 113 | -2x | +|||
| 194 | +
- correct = FALSE+ |
|||
| 114 | +195 |
- ),+ #' Discard Certain Levels from a Factor |
||
| 115 | -2x | +|||
| 196 | +
- "strat_newcombecc" = prop_diff_strat_nc(rsp,+ #' |
|||
| 116 | -2x | +|||
| 197 | +
- grp,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 117 | -2x | +|||
| 198 | +
- strata,+ #' |
|||
| 118 | -2x | +|||
| 199 | +
- weights_method,+ #' This discards the observations as well as the levels specified from a factor. |
|||
| 119 | -2x | +|||
| 200 | +
- conf_level,+ #' |
|||
| 120 | -2x | +|||
| 201 | +
- correct = TRUE+ #' @param x (`factor`)\cr the original factor.+ |
+ |||
| 202 | ++ |
+ #' @param discard (`character`)\cr which levels to discard. |
||
| 121 | +203 |
- ),+ #' |
||
| 122 | -2x | +|||
| 204 | +
- "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
+ #' @return A modified `factor` with observations as well as levels from `discard` dropped. |
|||
| 123 | +205 |
- )+ #' |
||
| 124 | +206 |
-
+ #' @examples |
||
| 125 | -2x | +|||
| 207 | +
- y$diff <- y$diff * 100+ #' fct_discard(factor(c("a", "b", "c")), "c")
|
|||
| 126 | -2x | +|||
| 208 | +
- y$diff_ci <- y$diff_ci * 100+ #' |
|||
| 127 | +209 |
- }+ #' @export |
||
| 128 | +210 |
-
+ fct_discard <- function(x, discard) {
|
||
| 129 | -2x | +211 | +301x |
- attr(y$diff, "label") <- "Difference in Response rate (%)"+ checkmate::assert_factor(x) |
| 130 | -2x | +212 | +301x |
- attr(y$diff_ci, "label") <- d_proportion_diff(+ checkmate::assert_character(discard, any.missing = FALSE) |
| 131 | -2x | +213 | +301x |
- conf_level, method,+ new_obs <- x[!(x %in% discard)] |
| 132 | -2x | +214 | +301x |
- long = FALSE+ new_levels <- setdiff(levels(x), discard)+ |
+
| 215 | +301x | +
+ factor(new_obs, levels = new_levels) |
||
| 133 | +216 |
- )+ } |
||
| 134 | +217 | |||
| 135 | -2x | +|||
| 218 | +
- y+ #' Insertion of Explicit Missings in a Factor |
|||
| 136 | +219 |
- }+ #' |
||
| 137 | +220 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 138 | +221 |
- #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.+ #' |
||
| 139 | +222 |
- #'+ #' This inserts explicit missings in a factor based on a condition. Additionally, |
||
| 140 | +223 |
- #' @return+ #' existing `NA` values will be explicitly converted to given `na_level`. |
||
| 141 | +224 |
- #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 142 | +225 |
- #'+ #' @param x (`factor`)\cr the original factor. |
||
| 143 | +226 |
- #' @examples+ #' @param condition (`logical`)\cr where to insert missings. |
||
| 144 | +227 |
- #' a_proportion_diff(+ #' @param na_level (`string`)\cr which level to use for missings. |
||
| 145 | +228 |
- #' df = subset(dta, grp == "A"),+ #' |
||
| 146 | +229 |
- #' .var = "rsp",+ #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`. |
||
| 147 | +230 |
- #' .ref_group = subset(dta, grp == "B"),+ #' |
||
| 148 | +231 |
- #' .in_ref_col = FALSE,+ #' @seealso [forcats::fct_na_value_to_level()] which is used internally. |
||
| 149 | +232 |
- #' conf_level = 0.90,+ #' |
||
| 150 | +233 |
- #' method = "ha"+ #' @examples |
||
| 151 | +234 |
- #' )+ #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
|
||
| 152 | +235 |
#' |
||
| 153 | +236 |
#' @export |
||
| 154 | +237 |
- a_proportion_diff <- make_afun(+ fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
|
||
| 155 | -+ | |||
| 238 | +1x |
- s_proportion_diff,+ checkmate::assert_factor(x, len = length(condition)) |
||
| 156 | -+ | |||
| 239 | +1x |
- .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),+ checkmate::assert_logical(condition) |
||
| 157 | -+ | |||
| 240 | +1x |
- .indent_mods = c(diff = 0L, diff_ci = 1L)+ x[condition] <- NA |
||
| 158 | -+ | |||
| 241 | +1x |
- )+ x <- forcats::fct_na_value_to_level(x, level = na_level) |
||
| 159 | -+ | |||
| 242 | +1x |
-
+ forcats::fct_drop(x, only = na_level) |
||
| 160 | +243 |
- #' @describeIn prop_diff Layout-creating function which can take statistics function arguments+ } |
||
| 161 | +244 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
||
| 162 | +245 |
- #'+ #' Collapsing of Factor Levels and Keeping Only Those New Group Levels |
||
| 163 | +246 |
- #' @return+ #' |
||
| 164 | +247 |
- #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ #' @description `r lifecycle::badge("stable")`
|
||
| 165 | +248 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 166 | +249 |
- #' the statistics from `s_proportion_diff()` to the table layout.+ #' This collapses levels and only keeps those new group levels, in the order provided. |
||
| 167 | +250 |
- #'+ #' The returned factor has levels in the order given, with the possible missing level last (this will |
||
| 168 | +251 |
- #' @examples+ #' only be included if there are missing values). |
||
| 169 | +252 |
- #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.+ #' |
||
| 170 | +253 |
- #' nex <- 100 # Number of example rows+ #' @param .f (`factor` or `character`)\cr original vector. |
||
| 171 | +254 |
- #' dta <- data.frame(+ #' @param ... (named `character` vectors)\cr levels in each vector provided will be collapsed into |
||
| 172 | +255 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ #' the new level given by the respective name. |
||
| 173 | +256 |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the |
||
| 174 | +257 |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ #' new factor. Note that this level must not be contained in the new levels specified in `...`. |
||
| 175 | +258 |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ #' |
||
| 176 | +259 |
- #' stringsAsFactors = TRUE+ #' @return A modified `factor` with collapsed levels. Values and levels which are not included |
||
| 177 | +260 |
- #' )+ #' in the given `character` vector input will be set to the missing level `.na_level`. |
||
| 178 | +261 |
#' |
||
| 179 | +262 |
- #' l <- basic_table() %>%+ #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed, |
||
| 180 | +263 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ #' [explicit_na()] can be called separately on the result. |
||
| 181 | +264 |
- #' estimate_proportion_diff(+ #' |
||
| 182 | +265 |
- #' vars = "rsp",+ #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally. |
||
| 183 | +266 |
- #' conf_level = 0.90,+ #' |
||
| 184 | +267 |
- #' method = "ha"+ #' @examples |
||
| 185 | +268 |
- #' )+ #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
|
||
| 186 | +269 |
#' |
||
| 187 | +270 |
- #' build_table(l, df = dta)+ #' @export |
||
| 188 | +271 |
- #'+ fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
|
||
| 189 | -+ | |||
| 272 | +4x |
- #' @export+ new_lvls <- names(list(...))+ |
+ ||
| 273 | +4x | +
+ if (checkmate::test_subset(.na_level, new_lvls)) {
+ |
+ ||
| 274 | +1x | +
+ stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
|
||
| 190 | +275 |
- #' @order 2+ }+ |
+ ||
| 276 | +3x | +
+ x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ |
+ ||
| 277 | +3x | +
+ do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls))) |
||
| 191 | +278 |
- estimate_proportion_diff <- function(lyt,+ } |
||
| 192 | +279 |
- vars,+ |
||
| 193 | +280 |
- variables = list(strata = NULL),+ #' Ungroup Non-Numeric Statistics |
||
| 194 | +281 |
- conf_level = 0.95,+ #' |
||
| 195 | +282 |
- method = c(+ #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`. |
||
| 196 | +283 |
- "waldcc", "wald", "cmh",+ #' |
||
| 197 | +284 |
- "ha", "newcombe", "newcombecc",+ #' @inheritParams argument_convention |
||
| 198 | +285 |
- "strat_newcombe", "strat_newcombecc"+ #' @param x (`named list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup. |
||
| 199 | +286 |
- ),+ #' |
||
| 200 | +287 |
- weights_method = "cmh",+ #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`. |
||
| 201 | +288 |
- na_str = default_na_str(),+ #' |
||
| 202 | +289 |
- nested = TRUE,+ #' @seealso [a_summary()] which uses this function internally. |
||
| 203 | +290 |
- ...,+ #' |
||
| 204 | +291 |
- var_labels = vars,+ #' @keywords internal |
||
| 205 | +292 |
- show_labels = "hidden",+ ungroup_stats <- function(x, |
||
| 206 | +293 |
- table_names = vars,+ .formats, |
||
| 207 | +294 |
- .stats = NULL,+ .labels, |
||
| 208 | +295 |
- .formats = NULL,+ .indent_mods) {
+ |
+ ||
| 296 | +276x | +
+ checkmate::assert_list(x)+ |
+ ||
| 297 | +276x | +
+ empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0+ |
+ ||
| 298 | +276x | +
+ empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0+ |
+ ||
| 299 | +276x | +
+ x <- unlist(x, recursive = FALSE) |
||
| 209 | +300 |
- .labels = NULL,+ |
||
| 210 | +301 |
- .indent_mods = NULL) {
+ # If p-value is empty it is removed by unlist and needs to be re-added+ |
+ ||
| 302 | +! | +
+ if (empty_pval) x[["pval"]] <- character() |
||
| 211 | -4x | +303 | +3x |
- extra_args <- list(+ if (empty_pval_counts) x[["pval_counts"]] <- character() |
| 212 | -4x | +304 | +276x |
- variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ...+ .stats <- names(x) |
| 213 | +305 |
- )+ |
||
| 214 | +306 |
-
+ # Ungroup stats |
||
| 215 | -4x | +307 | +276x |
- afun <- make_afun(+ .formats <- lapply(.stats, function(x) {
|
| 216 | -4x | +308 | +2273x |
- a_proportion_diff,+ .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ |
+
| 309 | ++ |
+ }) |
||
| 217 | -4x | +310 | +276x |
- .stats = .stats,+ .indent_mods <- sapply(.stats, function(x) {
|
| 218 | -4x | +311 | +2273x |
- .formats = .formats,+ .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ |
+
| 312 | ++ |
+ }) |
||
| 219 | -4x | +313 | +276x |
- .labels = .labels,+ .labels <- sapply(.stats, function(x) {
|
| 220 | -4x | +314 | +2216x |
- .indent_mods = .indent_mods+ if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
|
| 221 | +315 |
- )+ }) |
||
| 222 | +316 | |||
| 223 | -4x | +317 | +276x |
- analyze(+ list( |
| 224 | -4x | +318 | +276x |
- lyt,+ x = x, |
| 225 | -4x | +319 | +276x |
- vars,+ .formats = .formats, |
| 226 | -4x | +320 | +276x |
- afun = afun,+ .labels = .labels, |
| 227 | -4x | +321 | +276x |
- var_labels = var_labels,+ .indent_mods = .indent_mods |
| 228 | -4x | +|||
| 322 | +
- na_str = na_str,+ ) |
|||
| 229 | -4x | +|||
| 323 | +
- nested = nested,+ } |
|||
| 230 | -4x | +
| 1 | +
- extra_args = extra_args,+ #' Survival Time Analysis |
|||
| 231 | -4x | +|||
| 2 | +
- show_labels = show_labels,+ #' |
|||
| 232 | -4x | +|||
| 3 | +
- table_names = table_names+ #' @description `r lifecycle::badge("stable")`
|
|||
| 233 | +4 |
- )+ #' |
||
| 234 | +5 |
- }+ #' Summarize median survival time and CIs, percentiles of survival times, survival |
||
| 235 | +6 |
-
+ #' time range of censored/event patients. |
||
| 236 | +7 |
- #' Check: Proportion Difference Arguments+ #' |
||
| 237 | +8 |
- #'+ #' @inheritParams argument_convention |
||
| 238 | +9 |
- #' Verifies that and/or convert arguments into valid values to be used in the+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 239 | +10 |
- #' estimation of difference in responder proportions.+ #' [control_surv_time()]. Some possible parameter options are: |
||
| 240 | +11 |
- #'+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time. |
||
| 241 | +12 |
- #' @inheritParams prop_diff+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log", |
||
| 242 | +13 |
- #' @inheritParams prop_diff_wald+ #' see more in [survival::survfit()]. Note option "none" is not supported. |
||
| 243 | +14 |
- #'+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time. |
||
| 244 | +15 |
- #' @keywords internal+ #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed |
||
| 245 | +16 |
- check_diff_prop_ci <- function(rsp,+ #' when the `range` statistic is included. |
||
| 246 | +17 |
- grp,+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_time")`
|
||
| 247 | +18 |
- strata = NULL,+ #' to see available statistics for this function. |
||
| 248 | +19 |
- conf_level,+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 249 | +20 |
- correct = NULL) {
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 250 | -19x | +|||
| 21 | +
- checkmate::assert_logical(rsp, any.missing = FALSE)+ #' for that statistic's row label. |
|||
| 251 | -19x | +|||
| 22 | +
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ #' |
|||
| 252 | -19x | +|||
| 23 | +
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ #' @examples |
|||
| 253 | -19x | +|||
| 24 | +
- checkmate::assert_flag(correct, null.ok = TRUE)+ #' library(dplyr) |
|||
| 254 | +25 |
-
+ #' |
||
| 255 | -19x | +|||
| 26 | +
- if (!is.null(strata)) {
+ #' adtte_f <- tern_ex_adtte %>% |
|||
| 256 | -11x | +|||
| 27 | +
- checkmate::assert_factor(strata, len = length(rsp))+ #' filter(PARAMCD == "OS") %>% |
|||
| 257 | +28 |
- }+ #' mutate( |
||
| 258 | +29 |
-
+ #' AVAL = day2month(AVAL), |
||
| 259 | -19x | +|||
| 30 | +
- invisible()+ #' is_event = CNSR == 0 |
|||
| 260 | +31 |
- }+ #' ) |
||
| 261 | +32 |
-
+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 262 | +33 |
- #' Description of Method Used for Proportion Comparison+ #' |
||
| 263 | +34 |
- #'+ #' @name survival_time |
||
| 264 | +35 |
- #' @description `r lifecycle::badge("stable")`
+ #' @order 1 |
||
| 265 | +36 |
- #'+ NULL |
||
| 266 | +37 |
- #' This is an auxiliary function that describes the analysis in+ |
||
| 267 | +38 |
- #' `s_proportion_diff`.+ #' @describeIn survival_time Statistics function which analyzes survival times. |
||
| 268 | +39 |
#' |
||
| 269 | +40 |
- #' @inheritParams s_proportion_diff+ #' @return |
||
| 270 | +41 |
- #' @param long (`logical`)\cr Whether a long or a short (default) description is required.+ #' * `s_surv_time()` returns the statistics: |
||
| 271 | +42 |
- #'+ #' * `median`: Median survival time. |
||
| 272 | +43 |
- #' @return A `string` describing the analysis.+ #' * `median_ci`: Confidence interval for median time. |
||
| 273 | +44 |
- #'+ #' * `quantiles`: Survival time for two specified quantiles. |
||
| 274 | +45 |
- #' @seealso [prop_diff]+ #' * `range_censor`: Survival time range for censored observations. |
||
| 275 | +46 | ++ |
+ #' * `range_event`: Survival time range for observations with events.+ |
+ |
| 47 | ++ |
+ #' * `range`: Survival time range for all observations.+ |
+ ||
| 48 |
#' |
|||
| 276 | +49 |
- #' @export+ #' @keywords internal |
||
| 277 | +50 |
- d_proportion_diff <- function(conf_level,+ s_surv_time <- function(df, |
||
| 278 | +51 |
- method,+ .var, |
||
| 279 | +52 |
- long = FALSE) {
+ is_event,+ |
+ ||
| 53 | ++ |
+ control = control_surv_time()) {
|
||
| 280 | -11x | +54 | +182x |
- label <- paste0(conf_level * 100, "% CI")+ checkmate::assert_string(.var) |
| 281 | -11x | +55 | +182x |
- if (long) {
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 282 | -! | +|||
| 56 | +182x |
- label <- paste(+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
||
| 283 | -! | +|||
| 57 | +182x |
- label,+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
||
| 284 | -! | +|||
| 58 | +
- ifelse(+ |
|||
| 285 | -! | +|||
| 59 | +182x |
- method == "cmh",+ conf_type <- control$conf_type |
||
| 286 | -! | +|||
| 60 | +182x |
- "for adjusted difference",+ conf_level <- control$conf_level |
||
| 287 | -! | +|||
| 61 | +182x |
- "for difference"+ quantiles <- control$quantiles |
||
| 288 | +62 |
- )+ |
||
| 289 | -+ | |||
| 63 | +182x |
- )+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
||
| 290 | -+ | |||
| 64 | +182x |
- }+ srv_fit <- survival::survfit(+ |
+ ||
| 65 | +182x | +
+ formula = formula,+ |
+ ||
| 66 | +182x | +
+ data = df,+ |
+ ||
| 67 | +182x | +
+ conf.int = conf_level,+ |
+ ||
| 68 | +182x | +
+ conf.type = conf_type |
||
| 291 | +69 |
-
+ ) |
||
| 292 | -11x | +70 | +182x |
- method_part <- switch(method,+ srv_tab <- summary(srv_fit, extend = TRUE)$table |
| 293 | -11x | +71 | +182x |
- "cmh" = "CMH, without correction",+ srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile |
| 294 | -11x | +72 | +182x | +
+ range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)+ |
+
| 73 | +182x | +
+ range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)+ |
+ ||
| 74 | +182x | +
+ range <- range_noinf(df[[.var]], na.rm = TRUE)+ |
+ ||
| 75 | +182x | +
+ list(+ |
+ ||
| 76 | +182x | +
+ median = formatters::with_label(unname(srv_tab["median"]), "Median"),+ |
+ ||
| 77 | +182x | +
+ median_ci = formatters::with_label(+ |
+ ||
| 78 | +182x |
- "waldcc" = "Wald, with correction",+ unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
|
||
| 295 | -11x | +|||
| 79 | +
- "wald" = "Wald, without correction",+ ), |
|||
| 296 | -11x | +80 | +182x |
- "ha" = "Anderson-Hauck",+ quantiles = formatters::with_label( |
| 297 | -11x | +81 | +182x |
- "newcombe" = "Newcombe, without correction",+ unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile") |
| 298 | -11x | +|||
| 82 | +
- "newcombecc" = "Newcombe, with correction",+ ), |
|||
| 299 | -11x | +83 | +182x |
- "strat_newcombe" = "Stratified Newcombe, without correction",+ range_censor = formatters::with_label(range_censor, "Range (censored)"), |
| 300 | -11x | +84 | +182x |
- "strat_newcombecc" = "Stratified Newcombe, with correction",+ range_event = formatters::with_label(range_event, "Range (event)"), |
| 301 | -11x | +85 | +182x |
- stop(paste(method, "does not have a description"))+ range = formatters::with_label(range, "Range") |
| 302 | +86 |
) |
||
| 303 | -11x | -
- paste0(label, " (", method_part, ")")
- |
- ||
| 304 | +87 |
} |
||
| 305 | +88 | |||
| 306 | +89 |
- #' Helper Functions to Calculate Proportion Difference+ #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`. |
||
| 307 | +90 |
#' |
||
| 308 | +91 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 309 | +92 |
- #'+ #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 310 | +93 |
- #' @inheritParams argument_convention+ #' |
||
| 311 | +94 |
- #' @inheritParams prop_diff+ #' @examples |
||
| 312 | +95 |
- #' @param grp (`factor`)\cr vector assigning observations to one out of two groups+ #' a_surv_time( |
||
| 313 | +96 |
- #' (e.g. reference and treatment group).+ #' df, |
||
| 314 | +97 |
- #'+ #' .df_row = df, |
||
| 315 | +98 |
- #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci`+ #' .var = "AVAL", |
||
| 316 | +99 |
- #' (proportion difference confidence interval).+ #' is_event = "is_event" |
||
| 317 | +100 |
- #'+ #' ) |
||
| 318 | +101 |
- #' @seealso [prop_diff()] for implementation of these helper functions.+ #' |
||
| 319 | +102 |
- #'+ #' @export |
||
| 320 | +103 |
- #' @name h_prop_diff+ a_surv_time <- function(df, |
||
| 321 | +104 |
- NULL+ labelstr = "", |
||
| 322 | +105 |
-
+ .var = NULL, |
||
| 323 | +106 |
- #' @describeIn h_prop_diff The Wald interval follows the usual textbook+ .df_row = NULL, |
||
| 324 | +107 |
- #' definition for a single proportion confidence interval using the normal+ is_event, |
||
| 325 | +108 |
- #' approximation. It is possible to include a continuity correction for Wald's+ control = control_surv_time(), |
||
| 326 | +109 |
- #' interval.+ ref_fn_censor = TRUE, |
||
| 327 | +110 |
- #'+ .stats = NULL, |
||
| 328 | +111 |
- #' @param correct (`logical`)\cr whether to include the continuity correction. For further+ .formats = NULL, |
||
| 329 | +112 |
- #' information, see [stats::prop.test()].+ .labels = NULL, |
||
| 330 | +113 |
- #'+ .indent_mods = NULL, |
||
| 331 | +114 |
- #' @examples+ na_str = default_na_str()) {
|
||
| 332 | -+ | |||
| 115 | +12x |
- #' # Wald confidence interval+ x_stats <- s_surv_time( |
||
| 333 | -+ | |||
| 116 | +12x |
- #' set.seed(2)+ df = df, .var = .var, is_event = is_event, control = control |
||
| 334 | +117 |
- #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)+ ) |
||
| 335 | -+ | |||
| 118 | +12x |
- #' grp <- factor(c(rep("A", 10), rep("B", 10)))
+ rng_censor_lwr <- x_stats[["range_censor"]][1]+ |
+ ||
| 119 | +12x | +
+ rng_censor_upr <- x_stats[["range_censor"]][2] |
||
| 336 | +120 |
- #'+ |
||
| 337 | +121 |
- #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)+ # Use method-specific defaults+ |
+ ||
| 122 | +12x | +
+ fmts <- c(median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x")+ |
+ ||
| 123 | +12x | +
+ lbls <- c(median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)")+ |
+ ||
| 124 | +12x | +
+ lbls_custom <- .labels+ |
+ ||
| 125 | +12x | +
+ .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))])+ |
+ ||
| 126 | +12x | +
+ .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))]) |
||
| 338 | +127 |
- #'+ |
||
| 339 | +128 |
- #' @export+ # Fill in with formatting defaults if needed+ |
+ ||
| 129 | +12x | +
+ .stats <- get_stats("surv_time", stats_in = .stats)
+ |
+ ||
| 130 | +12x | +
+ .formats <- get_formats_from_stats(.stats, .formats)+ |
+ ||
| 131 | +12x | +
+ .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom)+ |
+ ||
| 132 | +12x | +
+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
||
| 340 | +133 |
- prop_diff_wald <- function(rsp,+ + |
+ ||
| 134 | +12x | +
+ x_stats <- x_stats[.stats] |
||
| 341 | +135 |
- grp,+ |
||
| 342 | +136 |
- conf_level = 0.95,+ # Auto format handling+ |
+ ||
| 137 | +12x | +
+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 343 | +138 |
- correct = FALSE) {
+
|
||
| 344 | -4x | +139 | +12x |
- if (isTRUE(correct)) {
+ cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
|
| 345 | -3x | +140 | +12x |
- mthd <- "waldcc"+ if ("range" %in% names(x_stats) && ref_fn_censor) {
|
| 346 | -+ | |||
| 141 | +12x |
- } else {
+ if (x_stats[["range"]][1] == rng_censor_lwr && x_stats[["range"]][2] == rng_censor_upr) {
|
||
| 347 | +142 | 1x |
- mthd <- "wald"+ cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum" |
|
| 348 | -+ | |||
| 143 | +11x |
- }+ } else if (x_stats[["range"]][1] == rng_censor_lwr) {
|
||
| 349 | -4x | +144 | +2x |
- grp <- as_factor_keep_attributes(grp)+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum" |
| 350 | -4x | +145 | +9x |
- check_diff_prop_ci(+ } else if (x_stats[["range"]][2] == rng_censor_upr) {
|
| 351 | -4x | +146 | +1x |
- rsp = rsp, grp = grp, conf_level = conf_level, correct = correct+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum" |
| 352 | +147 |
- )+ } |
||
| 353 | +148 |
-
+ } |
||
| 354 | +149 |
- # check if binary response is coded as logical+ |
||
| 355 | -4x | +150 | +12x |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ in_rows( |
| 356 | -4x | -
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)- |
- ||
| 357 | -+ | 151 | +12x |
-
+ .list = x_stats, |
| 358 | -4x | +152 | +12x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ .formats = .formats, |
| 359 | -+ | |||
| 153 | +12x |
- # x1 and n1 are non-reference groups.+ .names = .labels, |
||
| 360 | -4x | +154 | +12x |
- diff_ci <- desctools_binom(+ .labels = .labels, |
| 361 | -4x | +155 | +12x |
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ .indent_mods = .indent_mods, |
| 362 | -4x | +156 | +12x |
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ .format_na_strs = na_str, |
| 363 | -4x | +157 | +12x |
- conf.level = conf_level,+ .cell_footnotes = cell_fns |
| 364 | -4x | +|||
| 158 | +
- method = mthd+ ) |
|||
| 365 | +159 |
- )+ } |
||
| 366 | +160 | |||
| 367 | -4x | +|||
| 161 | +
- list(+ #' @describeIn survival_time Layout-creating function which can take statistics function arguments |
|||
| 368 | -4x | +|||
| 162 | +
- "diff" = unname(diff_ci[, "est"]),+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 369 | -4x | +|||
| 163 | +
- "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
+ #' |
|||
| 370 | +164 |
- )+ #' @return |
||
| 371 | +165 |
- }+ #' * `surv_time()` returns a layout object suitable for passing to further layouting functions, |
||
| 372 | +166 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 373 | +167 |
- #' @describeIn h_prop_diff Anderson-Hauck confidence interval.+ #' the statistics from `s_surv_time()` to the table layout. |
||
| 374 | +168 |
#' |
||
| 375 | +169 |
#' @examples |
||
| 376 | +170 |
- #' # Anderson-Hauck confidence interval+ #' basic_table() %>% |
||
| 377 | +171 |
- #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.+ #' split_cols_by(var = "ARMCD") %>% |
||
| 378 | +172 |
- #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)+ #' add_colcounts() %>% |
||
| 379 | +173 |
- #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
+ #' surv_time( |
||
| 380 | +174 |
- #'+ #' vars = "AVAL", |
||
| 381 | +175 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)+ #' var_labels = "Survival Time (Months)", |
||
| 382 | +176 |
- #'+ #' is_event = "is_event", |
||
| 383 | +177 |
- #' ## Edge case: Same proportion of response in A and B.+ #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log") |
||
| 384 | +178 |
- #' rsp <- c(TRUE, FALSE, TRUE, FALSE)+ #' ) %>% |
||
| 385 | +179 |
- #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ #' build_table(df = adtte_f) |
||
| 386 | +180 |
#' |
||
| 387 | +181 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)+ #' @export |
||
| 388 | +182 |
- #'+ #' @order 2 |
||
| 389 | +183 |
- #' @export+ surv_time <- function(lyt, |
||
| 390 | +184 |
- prop_diff_ha <- function(rsp,+ vars, |
||
| 391 | +185 |
- grp,+ is_event, |
||
| 392 | +186 |
- conf_level) {
+ control = control_surv_time(), |
||
| 393 | -3x | +|||
| 187 | +
- grp <- as_factor_keep_attributes(grp)+ ref_fn_censor = TRUE, |
|||
| 394 | -3x | +|||
| 188 | +
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ na_str = default_na_str(), |
|||
| 395 | +189 |
-
+ nested = TRUE, |
||
| 396 | -3x | +|||
| 190 | +
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ ..., |
|||
| 397 | +191 |
- # x1 and n1 are non-reference groups.+ var_labels = "Time to Event", |
||
| 398 | -3x | +|||
| 192 | +
- ci <- desctools_binom(+ show_labels = "visible", |
|||
| 399 | -3x | +|||
| 193 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ table_names = vars, |
|||
| 400 | -3x | +|||
| 194 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ .stats = c("median", "median_ci", "quantiles", "range"),
|
|||
| 401 | -3x | +|||
| 195 | +
- conf.level = conf_level,+ .formats = NULL, |
|||
| 402 | -3x | +|||
| 196 | +
- method = "ha"+ .labels = NULL, |
|||
| 403 | +197 |
- )+ .indent_mods = c(median_ci = 1L)) {
|
||
| 404 | +198 | 3x |
- list(+ extra_args <- list( |
|
| 405 | +199 | 3x |
- "diff" = unname(ci[, "est"]),+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str, |
|
| 406 | +200 | 3x |
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ... |
|
| 407 | +201 |
) |
||
| 408 | +202 |
- }+ |
||
| 409 | -+ | |||
| 203 | +3x |
-
+ analyze( |
||
| 410 | -+ | |||
| 204 | +3x |
- #' @describeIn h_prop_diff `Newcombe` confidence interval. It is based on+ lyt = lyt, |
||
| 411 | -+ | |||
| 205 | +3x |
- #' the Wilson score confidence interval for a single binomial proportion.+ vars = vars, |
||
| 412 | -+ | |||
| 206 | +3x |
- #'+ afun = a_surv_time, |
||
| 413 | -+ | |||
| 207 | +3x |
- #' @examples+ var_labels = var_labels, |
||
| 414 | -+ | |||
| 208 | +3x |
- #' # `Newcombe` confidence interval+ show_labels = show_labels, |
||
| 415 | -+ | |||
| 209 | +3x |
- #'+ table_names = table_names, |
||
| 416 | -+ | |||
| 210 | +3x |
- #' set.seed(1)+ na_str = na_str, |
||
| 417 | -+ | |||
| 211 | +3x |
- #' rsp <- c(+ nested = nested,+ |
+ ||
| 212 | +3x | +
+ extra_args = extra_args |
||
| 418 | +213 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),+ ) |
||
| 419 | +214 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)+ } |
| 420 | +1 |
- #' )+ #' Horizontal Waterfall Plot |
||
| 421 | +2 |
- #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
+ #' |
||
| 422 | +3 |
- #' table(rsp, grp)+ #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup. |
||
| 423 | +4 |
#' |
||
| 424 | +5 |
- #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)+ #' @description `r lifecycle::badge("stable")`
|
||
| 425 | +6 |
#' |
||
| 426 | +7 |
- #' @export+ #' @param height (`numeric``)\cr vector containing values to be plotted as the waterfall bars. |
||
| 427 | +8 |
- prop_diff_nc <- function(rsp,+ #' @param id (`character`)\cr vector containing IDs to use as the x-axis label for the waterfall bars. |
||
| 428 | +9 |
- grp,+ #' @param col (`character`)\cr colors. |
||
| 429 | +10 |
- conf_level,+ #' @param col_var (`factor`, `character` or `NULL`)\cr categorical variable for bar coloring. `NULL` by default. |
||
| 430 | +11 |
- correct = FALSE) {
+ #' @param xlab (`character`)\cr x label. Default is `"ID"`. |
||
| 431 | -1x | +|||
| 12 | +
- if (isTRUE(correct)) {
+ #' @param ylab (`character`)\cr y label. Default is `"Value"`. |
|||
| 432 | -! | +|||
| 13 | +
- mthd <- "scorecc"+ #' @param title (`character`)\cr text to be displayed as plot title. |
|||
| 433 | +14 |
- } else {
+ #' @param col_legend_title (`character`)\cr text to be displayed as legend title. |
||
| 434 | -1x | +|||
| 15 | +
- mthd <- "score"+ #' |
|||
| 435 | +16 |
- }+ #' @return A `ggplot` waterfall plot. |
||
| 436 | -1x | +|||
| 17 | +
- grp <- as_factor_keep_attributes(grp)+ #' |
|||
| 437 | -1x | +|||
| 18 | +
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ #' @examples |
|||
| 438 | +19 |
-
+ #' library(dplyr) |
||
| 439 | -1x | +|||
| 20 | +
- p_grp <- tapply(rsp, grp, mean)+ #' library(nestcolor) |
|||
| 440 | -1x | +|||
| 21 | +
- diff_p <- unname(diff(p_grp))+ #' |
|||
| 441 | -1x | +|||
| 22 | +
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ #' g_waterfall(height = c(3, 5, -1), id = letters[1:3]) |
|||
| 442 | -1x | +|||
| 23 | +
- ci <- desctools_binom(+ #' |
|||
| 443 | +24 |
- # x1 and n1 are non-reference groups.+ #' g_waterfall( |
||
| 444 | -1x | +|||
| 25 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ #' height = c(3, 5, -1), |
|||
| 445 | -1x | +|||
| 26 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ #' id = letters[1:3], |
|||
| 446 | -1x | +|||
| 27 | +
- conf.level = conf_level,+ #' col_var = letters[1:3] |
|||
| 447 | -1x | +|||
| 28 | +
- method = mthd+ #' ) |
|||
| 448 | +29 |
- )+ #' |
||
| 449 | -1x | +|||
| 30 | +
- list(+ #' adsl_f <- tern_ex_adsl %>% |
|||
| 450 | -1x | +|||
| 31 | +
- "diff" = unname(ci[, "est"]),+ #' select(USUBJID, STUDYID, ARM, ARMCD, SEX) |
|||
| 451 | -1x | +|||
| 32 | +
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ #' |
|||
| 452 | +33 |
- )+ #' adrs_f <- tern_ex_adrs %>% |
||
| 453 | +34 |
- }+ #' filter(PARAMCD == "OVRINV") %>% |
||
| 454 | +35 |
-
+ #' mutate(pchg = rnorm(n(), 10, 50)) |
||
| 455 | +36 |
- #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in+ #' |
||
| 456 | +37 |
- #' response rates between the experimental treatment group and the control treatment group, adjusted+ #' adrs_f <- head(adrs_f, 30) |
||
| 457 | +38 |
- #' for stratification factors by applying `Cochran-Mantel-Haenszel` (`CMH`) weights. For the `CMH` chi-squared+ #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ] |
||
| 458 | +39 |
- #' test, use [stats::mantelhaen.test()].+ #' head(adrs_f) |
||
| 459 | +40 |
#' |
||
| 460 | +41 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' g_waterfall( |
||
| 461 | +42 |
- #'+ #' height = adrs_f$pchg, |
||
| 462 | +43 |
- #' @examples+ #' id = adrs_f$USUBJID, |
||
| 463 | +44 |
- #' # Cochran-Mantel-Haenszel confidence interval+ #' col_var = adrs_f$AVALC |
||
| 464 | +45 |
- #'+ #' ) |
||
| 465 | +46 |
- #' set.seed(2)+ #' |
||
| 466 | +47 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ #' g_waterfall( |
||
| 467 | +48 |
- #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
+ #' height = adrs_f$pchg, |
||
| 468 | +49 |
- #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 469 | +50 |
- #' strata_data <- data.frame(+ #' col_var = adrs_f$SEX |
||
| 470 | +51 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' ) |
||
| 471 | +52 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' |
||
| 472 | +53 |
- #' stringsAsFactors = TRUE+ #' g_waterfall( |
||
| 473 | +54 |
- #' )+ #' height = adrs_f$pchg, |
||
| 474 | +55 |
- #'+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 475 | +56 |
- #' prop_diff_cmh(+ #' xlab = "ID", |
||
| 476 | +57 |
- #' rsp = rsp, grp = grp, strata = interaction(strata_data),+ #' ylab = "Percentage Change", |
||
| 477 | +58 |
- #' conf_level = 0.90+ #' title = "Waterfall plot" |
||
| 478 | +59 |
#' ) |
||
| 479 | +60 |
#' |
||
| 480 | +61 |
#' @export |
||
| 481 | +62 |
- prop_diff_cmh <- function(rsp,+ g_waterfall <- function(height, |
||
| 482 | +63 |
- grp,+ id, |
||
| 483 | +64 |
- strata,+ col_var = NULL, |
||
| 484 | +65 |
- conf_level = 0.95) {
- |
- ||
| 485 | -7x | -
- grp <- as_factor_keep_attributes(grp)- |
- ||
| 486 | -7x | -
- strata <- as_factor_keep_attributes(strata)+ col = getOption("ggplot2.discrete.colour"),
|
||
| 487 | -7x | +|||
| 66 | +
- check_diff_prop_ci(+ xlab = NULL, |
|||
| 488 | -7x | +|||
| 67 | +
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ ylab = NULL, |
|||
| 489 | +68 |
- )+ col_legend_title = NULL, |
||
| 490 | +69 |
-
+ title = NULL) {
|
||
| 491 | -7x | -
- if (any(tapply(rsp, strata, length) < 5)) {
- |
- ||
| 492 | -! | +70 | +2x |
- warning("Less than 5 observations in some strata.")
+ if (!is.null(col_var)) {
|
| 493 | -+ | |||
| 71 | +1x |
- }+ check_same_n(height = height, id = id, col_var = col_var) |
||
| 494 | +72 |
-
+ } else {
|
||
| 495 | -+ | |||
| 73 | +1x |
- # first dimension: FALSE, TRUE+ check_same_n(height = height, id = id) |
||
| 496 | +74 |
- # 2nd dimension: CONTROL, TX+ } |
||
| 497 | +75 |
- # 3rd dimension: levels of strat+ |
||
| 498 | -+ | |||
| 76 | +2x |
- # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records+ checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
|
||
| 499 | -7x | +77 | +2x |
- t_tbl <- table(+ checkmate::assert_character(col, null.ok = TRUE) |
| 500 | -7x | +|||
| 78 | +
- factor(rsp, levels = c("FALSE", "TRUE")),
+
|
|||
| 501 | -7x | +79 | +2x |
- grp,+ xlabel <- deparse(substitute(id)) |
| 502 | -7x | +80 | +2x |
- strata+ ylabel <- deparse(substitute(height)) |
| 503 | +81 |
- )- |
- ||
| 504 | -7x | -
- n1 <- colSums(t_tbl[1:2, 1, ])- |
- ||
| 505 | -7x | -
- n2 <- colSums(t_tbl[1:2, 2, ])+ |
||
| 506 | -7x | +82 | +2x |
- p1 <- t_tbl[2, 1, ] / n1+ col_label <- if (!missing(col_var)) {
|
| 507 | -7x | +83 | +1x |
- p2 <- t_tbl[2, 2, ] / n2+ deparse(substitute(col_var)) |
| 508 | +84 |
- # CMH weights+ } |
||
| 509 | -7x | +|||
| 85 | +
- use_stratum <- (n1 > 0) & (n2 > 0)+ |
|||
| 510 | -7x | +86 | +2x |
- n1 <- n1[use_stratum]+ xlab <- if (is.null(xlab)) xlabel else xlab |
| 511 | -7x | +87 | +2x |
- n2 <- n2[use_stratum]+ ylab <- if (is.null(ylab)) ylabel else ylab |
| 512 | -7x | +88 | +2x |
- p1 <- p1[use_stratum]+ col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title |
| 513 | -7x | +|||
| 89 | +
- p2 <- p2[use_stratum]+ |
|||
| 514 | -7x | +90 | +2x |
- wt <- (n1 * n2 / (n1 + n2))+ plot_data <- data.frame( |
| 515 | -7x | +91 | +2x |
- wt_normalized <- wt / sum(wt)+ height = height, |
| 516 | -7x | +92 | +2x |
- est1 <- sum(wt_normalized * p1)+ id = as.character(id), |
| 517 | -7x | +93 | +2x |
- est2 <- sum(wt_normalized * p2)+ col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)), |
| 518 | -7x | +94 | +2x |
- estimate <- c(est1, est2)+ stringsAsFactors = FALSE |
| 519 | -7x | +|||
| 95 | +
- names(estimate) <- levels(grp)+ ) |
|||
| 520 | -7x | +|||
| 96 | +
- se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))+ |
|||
| 521 | -7x | +97 | +2x |
- se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))+ plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ] |
| 522 | -7x | +|||
| 98 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ |
|||
| 523 | -7x | +99 | +2x |
- err1 <- z * se1+ p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) + |
| 524 | -7x | +100 | +2x |
- err2 <- z * se2+ ggplot2::geom_col() + |
| 525 | -7x | +101 | +2x |
- ci1 <- c((est1 - err1), (est1 + err1))+ ggplot2::geom_text( |
| 526 | -7x | +102 | +2x |
- ci2 <- c((est2 - err2), (est2 + err2))+ label = format(plot_data_ord$height, digits = 2), |
| 527 | -7x | +103 | +2x |
- estimate_ci <- list(ci1, ci2)+ vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5) |
| 528 | -7x | +|||
| 104 | +
- names(estimate_ci) <- levels(grp)+ ) + |
|||
| 529 | -7x | +105 | +2x |
- diff_est <- est2 - est1+ ggplot2::xlab(xlab) + |
| 530 | -7x | +106 | +2x |
- se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))+ ggplot2::ylab(ylab) + |
| 531 | -7x | +107 | +2x |
- diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5)) |
| 532 | +108 | |||
| 533 | -7x | +109 | +2x |
- list(+ if (!is.null(col_var)) {
|
| 534 | -7x | +110 | +1x |
- prop = estimate,+ p <- p + |
| 535 | -7x | +111 | +1x |
- prop_ci = estimate_ci,+ ggplot2::aes(fill = col_var) + |
| 536 | -7x | +112 | +1x |
- diff = diff_est,+ ggplot2::labs(fill = col_legend_title) + |
| 537 | -7x | +113 | +1x |
- diff_ci = diff_ci,+ ggplot2::theme( |
| 538 | -7x | +114 | +1x |
- weights = wt_normalized,+ legend.position = "bottom", |
| 539 | -7x | +115 | +1x |
- n1 = n1,+ legend.background = ggplot2::element_blank(), |
| 540 | -7x | +116 | +1x |
- n2 = n2+ legend.title = ggplot2::element_text(face = "bold"), |
| 541 | -+ | |||
| 117 | +1x |
- )+ legend.box.background = ggplot2::element_rect(colour = "black") |
||
| 542 | +118 |
- }+ ) |
||
| 543 | +119 |
-
+ } |
||
| 544 | +120 |
- #' @describeIn h_prop_diff Calculates the stratified `Newcombe` confidence interval and difference in response+ |
||
| 545 | -+ | |||
| 121 | +2x |
- #' rates between the experimental treatment group and the control treatment group, adjusted for stratification+ if (!is.null(col)) {
|
||
| 546 | -+ | |||
| 122 | +1x |
- #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
+ p <- p + |
||
| 547 | -+ | |||
| 123 | +1x |
- #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from `CMH`-derived weights+ ggplot2::scale_fill_manual(values = col) |
||
| 548 | +124 |
- #' (see [prop_diff_cmh()]).+ } |
||
| 549 | +125 |
- #'+ |
||
| 550 | -+ | |||
| 126 | +2x |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ if (!is.null(title)) {
|
||
| 551 | -+ | |||
| 127 | +1x |
- #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`+ p <- p + |
||
| 552 | -+ | |||
| 128 | +1x |
- #' and directs the way weights are estimated.+ ggplot2::labs(title = title) + |
||
| 553 | -+ | |||
| 129 | +1x |
- #'+ ggplot2::theme(plot.title = ggplot2::element_text(face = "bold")) |
||
| 554 | +130 |
- #' @references+ } |
||
| 555 | +131 |
- #' \insertRef{Yan2010-jt}{tern}
+
|
||
| 556 | -+ | |||
| 132 | +2x |
- #'+ p |
||
| 557 | +133 |
- #' @examples+ } |
| 558 | +1 |
- #' # Stratified `Newcombe` confidence interval+ #' Apply 1/3 or 1/2 Imputation Rule to Data |
||
| 559 | +2 |
#' |
||
| 560 | -- |
- #' set.seed(2)- |
- ||
| 561 | +3 |
- #' data_set <- data.frame(+ #' @description `r lifecycle::badge("stable")`
|
||
| 562 | +4 |
- #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE),+ #' |
||
| 563 | +5 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' @inheritParams argument_convention |
||
| 564 | +6 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' @param x_stats (`named list`)\cr a named list of statistics, typically the results of [s_summary()]. |
||
| 565 | +7 |
- #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
+ #' @param stat (`character`)\cr statistic to return the value/NA level of according to the imputation |
||
| 566 | +8 |
- #' stringsAsFactors = TRUE+ #' rule applied. |
||
| 567 | +9 |
- #' )+ #' @param imp_rule (`character`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation |
||
| 568 | +10 |
- #'+ #' rule or `"1/2"` to implement 1/2 imputation rule. |
||
| 569 | +11 |
- #' prop_diff_strat_nc(+ #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`). |
||
| 570 | +12 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ #' This parameter is only used when `imp_rule` is set to `"1/3"`. |
||
| 571 | +13 |
- #' weights_method = "cmh",+ #' @param avalcat_var (`character`)\cr name of variable that indicates whether a row in `df` corresponds |
||
| 572 | +14 |
- #' conf_level = 0.90+ #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above |
||
| 573 | +15 |
- #' )+ #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`. |
||
| 574 | +16 |
#' |
||
| 575 | +17 |
- #' prop_diff_strat_nc(+ #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed |
||
| 576 | +18 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ #' according to the specified imputation rule. |
||
| 577 | +19 |
- #' weights_method = "wilson_h",+ #' |
||
| 578 | +20 |
- #' conf_level = 0.90+ #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule` |
||
| 579 | +21 |
- #' )+ #' argument. |
||
| 580 | +22 |
#' |
||
| 581 | +23 |
- #' @export+ #' @examples |
||
| 582 | +24 |
- prop_diff_strat_nc <- function(rsp,+ #' set.seed(1) |
||
| 583 | +25 |
- grp,+ #' df <- data.frame( |
||
| 584 | +26 |
- strata,+ #' AVAL = runif(50, 0, 1), |
||
| 585 | +27 |
- weights_method = c("cmh", "wilson_h"),
+ #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE) |
||
| 586 | +28 |
- conf_level = 0.95,+ #' ) |
||
| 587 | +29 |
- correct = FALSE) {
- |
- ||
| 588 | -4x | -
- weights_method <- match.arg(weights_method)- |
- ||
| 589 | -4x | -
- grp <- as_factor_keep_attributes(grp)- |
- ||
| 590 | -4x | -
- strata <- as_factor_keep_attributes(strata)- |
- ||
| 591 | -4x | -
- check_diff_prop_ci(- |
- ||
| 592 | -4x | -
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ #' x_stats <- s_summary(df$AVAL) |
||
| 593 | +30 |
- )- |
- ||
| 594 | -4x | -
- checkmate::assert_number(conf_level, lower = 0, upper = 1)- |
- ||
| 595 | -4x | -
- checkmate::assert_flag(correct)- |
- ||
| 596 | -4x | -
- if (any(tapply(rsp, strata, length) < 5)) {
- |
- ||
| 597 | -! | -
- warning("Less than 5 observations in some strata.")
+ #' imputation_rule(df, x_stats, "max", "1/3") |
||
| 598 | +31 |
- }+ #' imputation_rule(df, x_stats, "geom_mean", "1/3") |
||
| 599 | +32 | - - | -||
| 600 | -4x | -
- rsp_by_grp <- split(rsp, f = grp)- |
- ||
| 601 | -4x | -
- strata_by_grp <- split(strata, f = grp)+ #' imputation_rule(df, x_stats, "mean", "1/2") |
||
| 602 | +33 |
-
+ #' |
||
| 603 | +34 |
- # Finding the weights+ #' @export |
||
| 604 | -4x | +|||
| 35 | +
- weights <- if (identical(weights_method, "cmh")) {
+ imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
|
|||
| 605 | -3x | +36 | +42x |
- prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights+ checkmate::assert_choice(avalcat_var, names(df)) |
| 606 | -4x | +37 | +42x |
- } else if (identical(weights_method, "wilson_h")) {
+ checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
|
| 607 | -1x | -
- prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights- |
- ||
| 608 | -+ | 38 | +42x |
- }+ n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
|
| 609 | -4x | +39 | +42x |
- weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0+ ltr_blq_ratio <- n_blq / max(1, nrow(df)) |
| 610 | +40 | |||
| 611 | +41 |
- # Calculating lower (`l`) and upper (`u`) confidence bounds per group.- |
- ||
| 612 | -4x | -
- strat_wilson_by_grp <- Map(- |
- ||
| 613 | -4x | -
- prop_strat_wilson,- |
- ||
| 614 | -4x | -
- rsp = rsp_by_grp,- |
- ||
| 615 | -4x | -
- strata = strata_by_grp,- |
- ||
| 616 | -4x | -
- weights = list(weights, weights),+ # defaults |
||
| 617 | -4x | +42 | +42x |
- conf_level = conf_level,+ val <- x_stats[[stat]] |
| 618 | -4x | -
- correct = correct- |
- ||
| 619 | -+ | 43 | +42x |
- )+ na_str <- "NE" |
| 620 | +44 | |||
| 621 | -4x | -
- ci_ref <- strat_wilson_by_grp[[1]]- |
- ||
| 622 | -4x | -
- ci_trt <- strat_wilson_by_grp[[2]]- |
- ||
| 623 | -4x | -
- l_ref <- as.numeric(ci_ref$conf_int[1])- |
- ||
| 624 | -4x | -
- u_ref <- as.numeric(ci_ref$conf_int[2])- |
- ||
| 625 | -4x | +45 | +42x |
- l_trt <- as.numeric(ci_trt$conf_int[1])+ if (imp_rule == "1/3") {
|
| 626 | -4x | -
- u_trt <- as.numeric(ci_trt$conf_int[2])- |
- ||
| 627 | -- | - - | -||
| 628 | -+ | 46 | +1x |
- # Estimating the diff and n_ref, n_trt (it allows different weights to be used)+ if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT |
| 629 | -4x | +47 | +41x |
- t_tbl <- table(+ if (ltr_blq_ratio > 1 / 3) {
|
| 630 | -4x | +48 | +29x |
- factor(rsp, levels = c("FALSE", "TRUE")),
+ if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT |
| 631 | +49 | 4x |
- grp,+ if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
|
|
| 632 | -4x | +50 | +18x |
- strata+ if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
|
| 633 | +51 |
- )- |
- ||
| 634 | -4x | -
- n_ref <- colSums(t_tbl[1:2, 1, ])- |
- ||
| 635 | -4x | -
- n_trt <- colSums(t_tbl[1:2, 2, ])- |
- ||
| 636 | -4x | -
- use_stratum <- (n_ref > 0) & (n_trt > 0)- |
- ||
| 637 | -4x | -
- n_ref <- n_ref[use_stratum]- |
- ||
| 638 | -4x | -
- n_trt <- n_trt[use_stratum]- |
- ||
| 639 | -4x | -
- p_ref <- t_tbl[2, 1, use_stratum] / n_ref+ } |
||
| 640 | -4x | +52 | +1x |
- p_trt <- t_tbl[2, 2, use_stratum] / n_trt+ } else if (imp_rule == "1/2") {
|
| 641 | -4x | +53 | +1x |
- est1 <- sum(weights * p_ref)+ if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
|
| 642 | -4x | +|||
| 54 | +! |
- est2 <- sum(weights * p_trt)+ val <- NA # 1/2_GT |
||
| 643 | -4x | +|||
| 55 | +! |
- diff_est <- est2 - est1+ na_str <- "ND" # 1/2_GT |
||
| 644 | +56 | - - | -||
| 645 | -4x | -
- lambda1 <- sum(weights^2 / n_ref)- |
- ||
| 646 | -4x | -
- lambda2 <- sum(weights^2 / n_trt)- |
- ||
| 647 | -4x | -
- z <- stats::qnorm((1 + conf_level) / 2)+ } |
||
| 648 | +57 | - - | -||
| 649 | -4x | -
- lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))- |
- ||
| 650 | -4x | -
- upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ } |
||
| 651 | +58 | |||
| 652 | -4x | -
- list(- |
- ||
| 653 | -4x | -
- "diff" = diff_est,- |
- ||
| 654 | -4x | -
- "diff_ci" = c("lower" = lower, "upper" = upper)
- |
- ||
| 655 | -+ | 59 | +42x |
- )+ list(val = val, na_str = na_str) |
| 656 | +60 |
}@@ -141476,14 +143357,14 @@ tern coverage - 90.46% |
| 1 |
- #' Multivariate Logistic Regression Table+ #' Tabulate Survival Duration by Subgroup |
|||
| 5 |
- #' Layout-creating function which summarizes a logistic variable regression for binary outcome with+ #' Tabulate statistics such as median survival time and hazard ratio for population subgroups. |
|||
| 6 |
- #' categorical/continuous covariates in model statement. For each covariate category (if categorical)+ #' |
|||
| 7 |
- #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and+ #' @inheritParams argument_convention |
|||
| 8 |
- #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate+ #' @inheritParams survival_coxph_pairwise |
|||
| 9 |
- #' category or specified values and corresponding Wald confidence intervals as default but allow user+ #' @param df (`list`)\cr of data frames containing all analysis variables. List should be |
|||
| 10 |
- #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis+ #' created using [extract_survival_subgroups()]. |
|||
| 11 |
- #' that covariate has no effect on response in model containing all specified covariates.+ #' @param vars (`character`)\cr the name of statistics to be reported among: |
|||
| 12 |
- #' Allow option to include one two-way interaction and present similar output for+ #' * `n_tot_events`: Total number of events per group. |
|||
| 13 |
- #' each interaction degree of freedom.+ #' * `n_events`: Number of events per group. |
|||
| 14 |
- #'+ #' * `n_tot`: Total number of observations per group. |
|||
| 15 |
- #' @inheritParams argument_convention+ #' * `n`: Number of observations per group. |
|||
| 16 |
- #' @param drop_and_remove_str (`character`)\cr string to be dropped and removed.+ #' * `median`: Median survival time. |
|||
| 17 |
- #'+ #' * `hr`: Hazard ratio. |
|||
| 18 |
- #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' * `ci`: Confidence interval of hazard ratio. |
|||
| 19 |
- #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout.+ #' * `pval`: p-value of the effect. |
|||
| 20 |
- #'+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` |
|||
| 21 |
- #' @note For the formula, the variable names need to be standard `data.frame` column names without+ #' are required. |
|||
| 22 |
- #' special characters.+ #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit. |
|||
| 24 |
- #' @examples+ #' @details These functions create a layout starting from a data frame which contains |
|||
| 25 |
- #' library(dplyr)+ #' the required statistics. Tables typically used as part of forest plot. |
|||
| 26 |
- #' library(broom)+ #' |
|||
| 27 |
- #'+ #' @seealso [extract_survival_subgroups()] |
|||
| 28 |
- #' adrs_f <- tern_ex_adrs %>%+ #' |
|||
| 29 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' @examples |
|||
| 30 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' library(dplyr) |
|||
| 31 |
- #' mutate(+ #' library(forcats) |
|||
| 32 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' |
|||
| 33 |
- #' RACE = factor(RACE),+ #' adtte <- tern_ex_adtte |
|||
| 34 |
- #' SEX = factor(SEX)+ #' |
|||
| 35 |
- #' )+ #' # Save variable labels before data processing steps. |
|||
| 36 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ #' adtte_labels <- formatters::var_labels(adtte) |
|||
| 37 |
- #' mod1 <- fit_logistic(+ #' |
|||
| 38 |
- #' data = adrs_f,+ #' adtte_f <- adtte %>% |
|||
| 39 |
- #' variables = list(+ #' filter( |
|||
| 40 |
- #' response = "Response",+ #' PARAMCD == "OS", |
|||
| 41 |
- #' arm = "ARMCD",+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
|||
| 42 |
- #' covariates = c("AGE", "RACE")
+ #' SEX %in% c("M", "F")
|
|||
| 43 |
- #' )+ #' ) %>% |
|||
| 44 |
- #' )+ #' mutate( |
|||
| 45 |
- #' mod2 <- fit_logistic(+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
|||
| 46 |
- #' data = adrs_f,+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
|||
| 47 |
- #' variables = list(+ #' SEX = droplevels(SEX), |
|||
| 48 |
- #' response = "Response",+ #' AVALU = as.character(AVALU), |
|||
| 49 |
- #' arm = "ARMCD",+ #' is_event = CNSR == 0 |
|||
| 50 |
- #' covariates = c("AGE", "RACE"),
+ #' ) |
|||
| 51 |
- #' interaction = "AGE"+ #' labels <- c( |
|||
| 52 |
- #' )+ #' "ARM" = adtte_labels[["ARM"]], |
|||
| 53 |
- #' )+ #' "SEX" = adtte_labels[["SEX"]], |
|||
| 54 |
- #'+ #' "AVALU" = adtte_labels[["AVALU"]], |
|||
| 55 |
- #' df <- tidy(mod1, conf_level = 0.99)+ #' "is_event" = "Event Flag" |
|||
| 56 |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ #' ) |
|||
| 57 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|||
| 58 |
- #' # flagging empty strings with "_"+ #' |
|||
| 59 |
- #' df <- df_explicit_na(df, na_level = "_")+ #' df <- extract_survival_subgroups( |
|||
| 60 |
- #' df2 <- df_explicit_na(df2, na_level = "_")+ #' variables = list( |
|||
| 61 |
- #'+ #' tte = "AVAL", |
|||
| 62 |
- #' result1 <- basic_table() %>%+ #' is_event = "is_event", |
|||
| 63 |
- #' summarize_logistic(+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
|||
| 64 |
- #' conf_level = 0.95,+ #' ), |
|||
| 65 |
- #' drop_and_remove_str = "_"+ #' data = adtte_f |
|||
| 66 |
- #' ) %>%+ #' ) |
|||
| 67 |
- #' build_table(df = df)+ #' df |
|||
| 68 |
- #' result1+ #' |
|||
| 69 |
- #'+ #' df_grouped <- extract_survival_subgroups( |
|||
| 70 |
- #' result2 <- basic_table() %>%+ #' variables = list( |
|||
| 71 |
- #' summarize_logistic(+ #' tte = "AVAL", |
|||
| 72 |
- #' conf_level = 0.95,+ #' is_event = "is_event", |
|||
| 73 |
- #' drop_and_remove_str = "_"+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
|||
| 74 |
- #' ) %>%+ #' ), |
|||
| 75 |
- #' build_table(df = df2)+ #' data = adtte_f, |
|||
| 76 |
- #' result2+ #' groups_lists = list( |
|||
| 77 |
- #'+ #' BMRKR2 = list( |
|||
| 78 |
- #' @export+ #' "low" = "LOW", |
|||
| 79 |
- #' @order 1+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 80 |
- summarize_logistic <- function(lyt,+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|||
| 81 |
- conf_level,+ #' ) |
|||
| 82 |
- drop_and_remove_str = "",+ #' ) |
|||
| 83 |
- .indent_mods = NULL) {
+ #' ) |
|||
| 84 |
- # checks+ #' df_grouped |
|||
| 85 | -3x | +
- checkmate::assert_string(drop_and_remove_str)+ #' |
||
| 86 |
-
+ #' @name survival_duration_subgroups |
|||
| 87 | -3x | +
- sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
+ #' @order 1 |
||
| 88 | -3x | +
- sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
+ NULL |
||
| 89 | -3x | +
- sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
+
|
||
| 90 | -3x | +
- split_fun <- drop_and_remove_levels(drop_and_remove_str)+ #' Prepares Survival Data for Population Subgroups in Data Frames |
||
| 91 |
-
+ #' |
|||
| 92 | -3x | +
- lyt <- logistic_regression_cols(lyt, conf_level = conf_level)+ #' @description `r lifecycle::badge("stable")`
|
||
| 93 | -3x | +
- lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun)+ #' |
||
| 94 | -3x | +
- lyt <- sum_logistic_variable_test(lyt)+ #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in |
||
| 95 | -3x | +
- lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun)+ #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list` |
||
| 96 | -3x | +
- lyt <- sum_logistic_term_estimates(lyt)+ #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`, |
||
| 97 | -3x | +
- lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun)+ #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`. |
||
| 98 | -3x | +
- lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun)+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 99 | -3x | +
- lyt <- sum_logistic_odds_ratios(lyt)+ #' |
||
| 100 | -3x | +
- lyt+ #' @inheritParams argument_convention |
||
| 101 |
- }+ #' @inheritParams survival_duration_subgroups |
|||
| 102 |
-
+ #' @inheritParams survival_coxph_pairwise |
|||
| 103 |
- #' Fit for Logistic Regression+ #' |
|||
| 104 |
- #'+ #' @return A named `list` of two elements: |
|||
| 105 |
- #' @description `r lifecycle::badge("stable")`
+ #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`, |
|||
| 106 |
- #'+ #' `var_label`, and `row_type`. |
|||
| 107 |
- #' Fit a (conditional) logistic regression model.+ #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`, |
|||
| 108 |
- #'+ #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
|||
| 109 |
- #' @inheritParams argument_convention+ #' |
|||
| 110 |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ #' @seealso [survival_duration_subgroups] |
|||
| 111 |
- #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ #' |
|||
| 112 |
- #' This will be used when fitting the (conditional) logistic regression model on the left hand+ #' @export |
|||
| 113 |
- #' side of the formula.+ extract_survival_subgroups <- function(variables, |
|||
| 114 |
- #'+ data, |
|||
| 115 |
- #' @return A fitted logistic regression model.+ groups_lists = list(), |
|||
| 116 |
- #'+ control = control_coxph(), |
|||
| 117 |
- #' @section Model Specification:+ label_all = "All Patients") {
|
|||
| 118 | -+ | 9x |
- #'+ if ("strat" %in% names(variables)) {
|
|
| 119 | -+ | ! |
- #' The `variables` list needs to include the following elements:+ warning( |
|
| 120 | -+ | ! |
- #' * `arm`: Treatment arm variable name.+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ", |
|
| 121 | -+ | ! |
- #' * `response`: The response arm variable name. Usually this is a 0/1 variable.+ "was deprecated in tern 0.9.3.\n ", |
|
| 122 | -+ | ! |
- #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names.+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
|
| 123 |
- #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already+ ) |
|||
| 124 | -+ | ! |
- #' included in `covariates`. Then the interaction with the treatment arm is included in the model.+ variables[["strata"]] <- variables[["strat"]] |
|
| 125 |
- #'+ } |
|||
| 126 |
- #' @examples+ |
|||
| 127 | -+ | 9x |
- #' library(dplyr)+ df_survtime <- h_survtime_subgroups_df( |
|
| 128 | -+ | 9x |
- #'+ variables, |
|
| 129 | -+ | 9x |
- #' adrs_f <- tern_ex_adrs %>%+ data, |
|
| 130 | -+ | 9x |
- #' filter(PARAMCD == "BESRSPI") %>%+ groups_lists = groups_lists, |
|
| 131 | -+ | 9x |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ label_all = label_all |
|
| 132 |
- #' mutate(+ ) |
|||
| 133 | -+ | 9x |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ df_hr <- h_coxph_subgroups_df( |
|
| 134 | -+ | 9x |
- #' RACE = factor(RACE),+ variables, |
|
| 135 | -+ | 9x |
- #' SEX = factor(SEX)+ data, |
|
| 136 | -+ | 9x |
- #' )+ groups_lists = groups_lists, |
|
| 137 | -+ | 9x |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ control = control, |
|
| 138 | -+ | 9x |
- #' mod1 <- fit_logistic(+ label_all = label_all |
|
| 139 |
- #' data = adrs_f,+ ) |
|||
| 140 |
- #' variables = list(+ |
|||
| 141 | -+ | 9x |
- #' response = "Response",+ list(survtime = df_survtime, hr = df_hr) |
|
| 142 |
- #' arm = "ARMCD",+ } |
|||
| 143 |
- #' covariates = c("AGE", "RACE")
+
|
|||
| 144 |
- #' )+ #' @describeIn survival_duration_subgroups Formatted analysis function which is used as |
|||
| 145 |
- #' )+ #' `afun` in `tabulate_survival_subgroups()`. |
|||
| 146 |
- #' mod2 <- fit_logistic(+ #' |
|||
| 147 |
- #' data = adrs_f,+ #' @return |
|||
| 148 |
- #' variables = list(+ #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 149 |
- #' response = "Response",+ #' |
|||
| 150 |
- #' arm = "ARMCD",+ #' @keywords internal |
|||
| 151 |
- #' covariates = c("AGE", "RACE"),
+ a_survival_subgroups <- function(.formats = list( # nolint start |
|||
| 152 |
- #' interaction = "AGE"+ n = "xx", |
|||
| 153 |
- #' )+ n_events = "xx", |
|||
| 154 |
- #' )+ n_tot_events = "xx", |
|||
| 155 |
- #'+ median = "xx.x", |
|||
| 156 |
- #' @export+ n_tot = "xx", |
|||
| 157 |
- fit_logistic <- function(data,+ hr = list(format_extreme_values(2L)), |
|||
| 158 |
- variables = list(+ ci = list(format_extreme_values_ci(2L)), |
|||
| 159 |
- response = "Response",+ pval = "x.xxxx | (<0.0001)" |
|||
| 160 |
- arm = "ARMCD",+ ), |
|||
| 161 |
- covariates = NULL,+ na_str = default_na_str()) { # nolint end
|
|||
| 162 | -+ | 15x |
- interaction = NULL,+ checkmate::assert_list(.formats) |
|
| 163 | -+ | 15x |
- strata = NULL+ checkmate::assert_subset( |
|
| 164 | -+ | 15x |
- ),+ names(.formats), |
|
| 165 | -+ | 15x |
- response_definition = "response") {
+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
|
|
| 166 | -74x | +
- assert_df_with_variables(data, variables)+ ) |
||
| 167 | -74x | +
- checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
+
|
||
| 168 | -74x | +15x |
- checkmate::assert_string(response_definition)+ afun_lst <- Map( |
|
| 169 | -74x | +15x |
- checkmate::assert_true(grepl("response", response_definition))
+ function(stat, fmt, na_str) {
|
|
| 170 | -+ | 114x |
-
+ if (stat == "ci") {
|
|
| 171 | -74x | +14x |
- response_definition <- sub(+ function(df, labelstr = "", ...) {
|
|
| 172 | -74x | +29x |
- pattern = "response",+ in_rows( |
|
| 173 | -74x | +29x |
- replacement = variables$response,+ .list = combine_vectors(df$lcl, df$ucl), |
|
| 174 | -74x | +29x |
- x = response_definition,+ .labels = as.character(df$subgroup), |
|
| 175 | -74x | +29x |
- fixed = TRUE+ .formats = fmt, |
|
| 176 | -+ | 29x |
- )+ .format_na_strs = na_str |
|
| 177 | -74x | +
- form <- paste0(response_definition, " ~ ", variables$arm)+ ) |
||
| 178 | -74x | +
- if (!is.null(variables$covariates)) {
+ } |
||
| 179 | -28x | +
- form <- paste0(form, " + ", paste(variables$covariates, collapse = " + "))+ } else {
|
||
| 180 | -+ | 100x |
- }+ function(df, labelstr = "", ...) {
|
|
| 181 | -74x | +159x |
- if (!is.null(variables$interaction)) {
+ in_rows( |
|
| 182 | -17x | +159x |
- checkmate::assert_string(variables$interaction)+ .list = as.list(df[[stat]]), |
|
| 183 | -17x | +159x |
- checkmate::assert_subset(variables$interaction, variables$covariates)+ .labels = as.character(df$subgroup), |
|
| 184 | -17x | +159x |
- form <- paste0(form, " + ", variables$arm, ":", variables$interaction)+ .formats = fmt, |
|
| 185 | -+ | 159x |
- }+ .format_na_strs = na_str |
|
| 186 | -74x | +
- if (!is.null(variables$strata)) {
+ ) |
||
| 187 | -14x | +
- strata_arg <- if (length(variables$strata) > 1) {
+ } |
||
| 188 | -7x | +
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ } |
||
| 189 |
- } else {
+ }, |
|||
| 190 | -7x | +15x |
- variables$strata+ stat = names(.formats), |
|
| 191 | -+ | 15x |
- }+ fmt = .formats, |
|
| 192 | -14x | +15x |
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ na_str = na_str |
|
| 193 |
- }+ ) |
|||
| 194 | -74x | +
- formula <- stats::as.formula(form)+ |
||
| 195 | -74x | +15x |
- if (is.null(variables$strata)) {
+ afun_lst |
|
| 196 | -60x | +
- stats::glm(+ } |
||
| 197 | -60x | +
- formula = formula,+ |
||
| 198 | -60x | +
- data = data,+ #' @describeIn survival_duration_subgroups Table-creating function which creates a table |
||
| 199 | -60x | +
- family = stats::binomial("logit")
+ #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
||
| 200 |
- )+ #' and [rtables::summarize_row_groups()]. |
|||
| 201 |
- } else {
+ #' |
|||
| 202 | -14x | +
- clogit_with_tryCatch(+ #' @return An `rtables` table summarizing survival by subgroup. |
||
| 203 | -14x | +
- formula = formula,+ #' |
||
| 204 | -14x | +
- data = data,+ #' @examples |
||
| 205 | -14x | +
- x = TRUE+ #' ## Table with default columns. |
||
| 206 |
- )+ #' basic_table() %>% |
|||
| 207 |
- }+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
|||
| 208 |
- }+ #' |
|||
| 209 |
-
+ #' ## Table with a manually chosen set of columns: adding "pval". |
|||
| 210 |
- #' Custom Tidy Method for Binomial GLM Results+ #' basic_table() %>% |
|||
| 211 |
- #'+ #' tabulate_survival_subgroups( |
|||
| 212 |
- #' @description `r lifecycle::badge("stable")`
+ #' df = df, |
|||
| 213 |
- #'+ #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
|
|||
| 214 |
- #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object+ #' time_unit = adtte_f$AVALU[1] |
|||
| 215 |
- #' with `binomial` family.+ #' ) |
|||
| 217 |
- #' @inheritParams argument_convention+ #' @export |
|||
| 218 |
- #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise the median is used.+ #' @order 2 |
|||
| 219 |
- #' @param x logistic regression model fitted by [stats::glm()] with "binomial" family.+ tabulate_survival_subgroups <- function(lyt, |
|||
| 220 |
- #'+ df, |
|||
| 221 |
- #' @return A `data.frame` containing the tidied model.+ vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
|
|||
| 222 |
- #'+ groups_lists = list(), |
|||
| 223 |
- #' @method tidy glm+ label_all = "All Patients", |
|||
| 224 |
- #'+ time_unit = NULL, |
|||
| 225 |
- #' @seealso [h_logistic_regression] for relevant helper functions.+ na_str = default_na_str()) {
|
|||
| 226 | -+ | 6x |
- #'+ conf_level <- df$hr$conf_level[1] |
|
| 227 | -+ | 6x |
- #' @examples+ method <- df$hr$pval_label[1] |
|
| 228 |
- #' library(dplyr)+ |
|||
| 229 | -+ | 6x |
- #' library(broom)+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all) |
|
| 230 |
- #'+ |
|||
| 231 | -+ | 6x |
- #' adrs_f <- tern_ex_adrs %>%+ afun_lst <- a_survival_subgroups(na_str = na_str) |
|
| 232 | -+ | 6x |
- #' filter(PARAMCD == "BESRSPI") %>%+ colvars <- d_survival_subgroups_colvars( |
|
| 233 | -+ | 6x |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ vars, |
|
| 234 | -+ | 6x |
- #' mutate(+ conf_level = conf_level, |
|
| 235 | -+ | 6x |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ method = method, |
|
| 236 | -+ | 6x |
- #' RACE = factor(RACE),+ time_unit = time_unit |
|
| 237 |
- #' SEX = factor(SEX)+ ) |
|||
| 238 |
- #' )+ |
|||
| 239 | -+ | 6x |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ colvars_survtime <- list( |
|
| 240 | -+ | 6x |
- #' mod1 <- fit_logistic(+ vars = colvars$vars[names(colvars$labels) %in% c("n", "n_events", "median")],
|
|
| 241 | -+ | 6x |
- #' data = adrs_f,+ labels = colvars$labels[names(colvars$labels) %in% c("n", "n_events", "median")]
|
|
| 242 |
- #' variables = list(+ ) |
|||
| 243 | -+ | 6x |
- #' response = "Response",+ colvars_hr <- list( |
|
| 244 | -+ | 6x |
- #' arm = "ARMCD",+ vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")],
|
|
| 245 | -+ | 6x |
- #' covariates = c("AGE", "RACE")
+ labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")]
|
|
| 246 |
- #' )+ ) |
|||
| 247 |
- #' )+ |
|||
| 248 |
- #' mod2 <- fit_logistic(+ # Columns from table_survtime are optional. |
|||
| 249 | -+ | 6x |
- #' data = adrs_f,+ if (length(colvars_survtime$vars) > 0) {
|
|
| 250 | -+ | 5x |
- #' variables = list(+ lyt_survtime <- split_cols_by(lyt = lyt, var = "arm") |
|
| 251 | -+ | 5x |
- #' response = "Response",+ lyt_survtime <- split_rows_by( |
|
| 252 | -+ | 5x |
- #' arm = "ARMCD",+ lyt = lyt_survtime, |
|
| 253 | -+ | 5x |
- #' covariates = c("AGE", "RACE"),
+ var = "row_type", |
|
| 254 | -+ | 5x |
- #' interaction = "AGE"+ split_fun = keep_split_levels("content"),
|
|
| 255 | -+ | 5x |
- #' )+ nested = FALSE |
|
| 256 |
- #' )+ ) |
|||
| 257 | -+ | 5x |
- #'+ lyt_survtime <- summarize_row_groups( |
|
| 258 | -+ | 5x |
- #' df <- tidy(mod1, conf_level = 0.99)+ lyt = lyt_survtime, |
|
| 259 | -+ | 5x |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ var = "var_label", |
|
| 260 | -+ | 5x |
- #'+ cfun = afun_lst[names(colvars_survtime$labels)], |
|
| 261 | -+ | 5x |
- #' @export+ na_str = na_str, |
|
| 262 | -+ | 5x |
- tidy.glm <- function(x, # nolint+ extra_args = extra_args |
|
| 263 |
- conf_level = 0.95,+ ) |
|||
| 264 | -+ | 5x |
- at = NULL,+ lyt_survtime <- split_cols_by_multivar( |
|
| 265 | -+ | 5x |
- ...) {
+ lyt = lyt_survtime, |
|
| 266 | 5x |
- checkmate::assert_class(x, "glm")+ vars = colvars_survtime$vars, |
||
| 267 | 5x |
- checkmate::assert_set_equal(x$family$family, "binomial")+ varlabels = colvars_survtime$labels |
||
| 268 |
-
+ ) |
|||
| 269 | -5x | +
- terms_name <- attr(stats::terms(x), "term.labels")+ |
||
| 270 | 5x |
- xs_class <- attr(x$terms, "dataClasses")+ if ("analysis" %in% df$survtime$row_type) {
|
||
| 271 | -5x | +4x |
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ lyt_survtime <- split_rows_by( |
|
| 272 | -5x | +4x |
- df <- if (length(interaction) == 0) {
+ lyt = lyt_survtime, |
|
| 273 | -2x | +4x |
- h_logistic_simple_terms(+ var = "row_type", |
|
| 274 | -2x | +4x |
- x = terms_name,+ split_fun = keep_split_levels("analysis"),
|
|
| 275 | -2x | +4x |
- fit_glm = x,+ nested = FALSE, |
|
| 276 | -2x | +4x |
- conf_level = conf_level+ child_labels = "hidden" |
|
| 277 |
- )+ ) |
|||
| 278 | -+ | 4x |
- } else {
+ lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE) |
|
| 279 | -3x | +4x |
- h_logistic_inter_terms(+ lyt_survtime <- analyze_colvars( |
|
| 280 | -3x | +4x |
- x = terms_name,+ lyt = lyt_survtime, |
|
| 281 | -3x | +4x |
- fit_glm = x,+ afun = afun_lst[names(colvars_survtime$labels)], |
|
| 282 | -3x | +4x |
- conf_level = conf_level,+ na_str = na_str, |
|
| 283 | -3x | +4x |
- at = at+ inclNAs = TRUE, |
|
| 284 | -+ | 4x |
- )+ extra_args = extra_args |
|
| 285 |
- }+ ) |
|||
| 286 | -5x | +
- for (var in c("variable", "term", "interaction", "reference")) {
+ } |
||
| 287 | -20x | +
- df[[var]] <- factor(df[[var]], levels = unique(df[[var]]))+ |
||
| 288 | -+ | 5x |
- }+ table_survtime <- build_table(lyt_survtime, df = df$survtime) |
|
| 289 | -5x | +
- df+ } else {
|
||
| 290 | -+ | 1x |
- }+ table_survtime <- NULL |
|
| 291 |
-
+ } |
|||
| 292 |
- #' Logistic Regression Multivariate Column Layout Function+ |
|||
| 293 |
- #'+ # Columns "n_tot_events" or "n_tot", and "hr", "ci" in table_hr are required. |
|||
| 294 | -+ | 6x |
- #' @description `r lifecycle::badge("stable")`
+ lyt_hr <- split_cols_by(lyt = lyt, var = "arm") |
|
| 295 | -+ | 6x |
- #'+ lyt_hr <- split_rows_by( |
|
| 296 | -+ | 6x |
- #' Layout-creating function which creates a multivariate column layout summarizing logistic+ lyt = lyt_hr, |
|
| 297 | -+ | 6x |
- #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()].+ var = "row_type", |
|
| 298 | -+ | 6x |
- #'+ split_fun = keep_split_levels("content"),
|
|
| 299 | -+ | 6x |
- #' @inheritParams argument_convention+ nested = FALSE |
|
| 300 |
- #'+ ) |
|||
| 301 | -+ | 6x |
- #' @return A layout object suitable for passing to further layouting functions. Adding this+ lyt_hr <- summarize_row_groups( |
|
| 302 | -+ | 6x |
- #' function to an `rtable` layout will split the table into columns corresponding to+ lyt = lyt_hr, |
|
| 303 | -+ | 6x |
- #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`.+ var = "var_label", |
|
| 304 | -+ | 6x |
- #'+ cfun = afun_lst[names(colvars_hr$labels)], |
|
| 305 | -+ | 6x |
- #' @export+ na_str = na_str, |
|
| 306 | -+ | 6x |
- logistic_regression_cols <- function(lyt,+ extra_args = extra_args |
|
| 307 |
- conf_level = 0.95) {
+ ) |
|||
| 308 | -4x | +6x |
- vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
+ lyt_hr <- split_cols_by_multivar( |
|
| 309 | -4x | +6x |
- var_labels <- c(+ lyt = lyt_hr, |
|
| 310 | -4x | +6x |
- df = "Degrees of Freedom",+ vars = colvars_hr$vars, |
|
| 311 | -4x | +6x |
- estimate = "Parameter Estimate",+ varlabels = colvars_hr$labels |
|
| 312 | -4x | +
- std_error = "Standard Error",+ ) %>% |
||
| 313 | -4x | +6x |
- odds_ratio = "Odds Ratio",+ append_topleft("Baseline Risk Factors")
|
|
| 314 | -4x | +
- ci = paste("Wald", f_conf_level(conf_level)),
+
|
||
| 315 | -4x | +6x |
- pvalue = "p-value"+ if ("analysis" %in% df$survtime$row_type) {
|
|
| 316 | -+ | 5x |
- )+ lyt_hr <- split_rows_by( |
|
| 317 | -4x | +5x |
- split_cols_by_multivar(+ lyt = lyt_hr, |
|
| 318 | -4x | +5x |
- lyt = lyt,+ var = "row_type", |
|
| 319 | -4x | +5x |
- vars = vars,+ split_fun = keep_split_levels("analysis"),
|
|
| 320 | -4x | +5x |
- varlabels = var_labels+ nested = FALSE, |
|
| 321 | +5x | +
+ child_labels = "hidden"+ |
+ ||
| 322 | ++ |
+ )+ |
+ ||
| 323 | +5x | +
+ lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)+ |
+ ||
| 324 | +5x | +
+ lyt_hr <- analyze_colvars(+ |
+ ||
| 325 | +5x | +
+ lyt = lyt_hr,+ |
+ ||
| 326 | +5x | +
+ afun = afun_lst[names(colvars_hr$labels)],+ |
+ ||
| 327 | +5x | +
+ na_str = na_str,+ |
+ ||
| 328 | +5x | +
+ inclNAs = TRUE,+ |
+ ||
| 329 | +5x | +
+ extra_args = extra_args+ |
+ ||
| 330 | ++ |
+ )+ |
+ ||
| 331 | ++ |
+ }+ |
+ ||
| 332 | +6x | +
+ table_hr <- build_table(lyt_hr, df = df$hr)+ |
+ ||
| 333 | ++ | + + | +||
| 334 | ++ |
+ # There can be one or two vars starting with "n_tot".+ |
+ ||
| 335 | +6x | +
+ n_tot_ids <- grep("^n_tot", colvars_hr$vars)
+ |
+ ||
| 336 | +6x | +
+ if (is.null(table_survtime)) {
+ |
+ ||
| 337 | +1x | +
+ result <- table_hr+ |
+ ||
| 338 | +1x | +
+ hr_id <- match("hr", colvars_hr$vars)
+ |
+ ||
| 339 | +1x | +
+ ci_id <- match("lcl", colvars_hr$vars)
+ |
+ ||
| 340 | ++ |
+ } else {
+ |
+ ||
| 341 | ++ |
+ # Reorder the table.+ |
+ ||
| 342 | +5x | +
+ result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])+ |
+ ||
| 343 | ++ |
+ # And then calculate column indices accordingly.+ |
+ ||
| 344 | +5x | +
+ hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
+ |
+ ||
| 345 | +5x | +
+ ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("lcl", colvars_hr$vars[-n_tot_ids])
+ |
+ ||
| 346 | +5x | +
+ n_tot_ids <- seq_along(n_tot_ids)+ |
+ ||
| 347 | ++ |
+ }+ |
+ ||
| 348 | ++ | + + | +||
| 349 | +6x | +
+ structure(+ |
+ ||
| 350 | +6x | +
+ result,+ |
+ ||
| 351 | +6x | +
+ forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ |
+ ||
| 352 | +6x | +
+ col_x = hr_id,+ |
+ ||
| 353 | +6x | +
+ col_ci = ci_id,+ |
+ ||
| 354 | ++ |
+ # Take the first one for scaling the symbol sizes in graph.+ |
+ ||
| 355 | +6x | +
+ col_symbol_size = n_tot_ids[1]+ |
+ ||
| 356 |
) |
|||
| 322 | +357 |
} |
||
| 323 | +358 | |||
| 324 | +359 |
- #' Logistic Regression Summary Table Constructor Function+ #' Labels for Column Variables in Survival Duration by Subgroup Table |
||
| 325 | +360 |
#' |
||
| 326 | +361 |
#' @description `r lifecycle::badge("stable")`
|
||
| 327 | +362 |
#' |
||
| 328 | +363 |
- #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize+ #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels. |
||
| 329 | +364 |
- #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()].+ #' |
||
| 330 | +365 |
- #'+ #' @inheritParams tabulate_survival_subgroups |
||
| 331 | +366 |
#' @inheritParams argument_convention |
||
| 332 | +367 |
- #' @param flag_var (`string`)\cr variable name identifying which row should be used in this+ #' @param method (`character`)\cr p-value method for testing hazard ratio = 1. |
||
| 333 | +368 |
- #' content function.+ #' |
||
| 334 | +369 | ++ |
+ #' @return A `list` of variables and their labels to tabulate.+ |
+ |
| 370 |
#' |
|||
| 335 | +371 |
- #' @return A content function.+ #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`. |
||
| 336 | +372 |
#' |
||
| 337 | +373 |
#' @export |
||
| 338 | +374 |
- logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
+ d_survival_subgroups_colvars <- function(vars,+ |
+ ||
| 375 | ++ |
+ conf_level,+ |
+ ||
| 376 | ++ |
+ method,+ |
+ ||
| 377 | ++ |
+ time_unit = NULL) {
|
||
| 339 | -10x | +378 | +15x |
- checkmate::assert_string(flag_var)+ checkmate::assert_character(vars) |
| 340 | -10x | +379 | +15x |
- function(lyt) {
+ checkmate::assert_string(time_unit, null.ok = TRUE) |
| 341 | -10x | +380 | +15x |
- cfun_list <- list(+ checkmate::assert_subset(c("hr", "ci"), vars)
|
| 342 | -10x | +381 | +15x |
- df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
|
| 343 | -10x | +382 | +15x |
- estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ checkmate::assert_subset( |
| 344 | -10x | +383 | +15x |
- std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ vars, |
| 345 | -10x | +384 | +15x |
- odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ |
+
| 385 | ++ |
+ )+ |
+ ||
| 386 | ++ | + | ||
| 346 | -10x | +387 | +15x |
- ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
+ propcase_time_label <- if (!is.null(time_unit)) {
|
| 347 | -10x | +388 | +14x |
- pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
+ paste0("Median (", time_unit, ")")
|
| 348 | +389 |
- )+ } else {
|
||
| 349 | -10x | +390 | +1x |
- summarize_row_groups(+ "Median"+ |
+
| 391 | ++ |
+ }+ |
+ ||
| 392 | ++ | + | ||
| 350 | -10x | +393 | +15x |
- lyt = lyt,+ varlabels <- c( |
| 351 | -10x | +394 | +15x |
- cfun = cfun_list,+ n = "n", |
| 352 | -10x | +395 | +15x |
- na_str = na_str+ n_events = "Events",+ |
+
| 396 | +15x | +
+ median = propcase_time_label,+ |
+ ||
| 397 | +15x | +
+ n_tot = "Total n",+ |
+ ||
| 398 | +15x | +
+ n_tot_events = "Total Events",+ |
+ ||
| 399 | +15x | +
+ hr = "Hazard Ratio",+ |
+ ||
| 400 | +15x | +
+ ci = paste0(100 * conf_level, "% Wald CI"),+ |
+ ||
| 401 | +15x | +
+ pval = method |
||
| 353 | +402 |
- )+ ) |
||
| 354 | +403 |
- }+ + |
+ ||
| 404 | +15x | +
+ colvars <- vars |
||
| 355 | +405 | ++ | + + | +|
| 406 | ++ |
+ # The `lcl` variable is just a placeholder available in the analysis data,+ |
+ ||
| 407 | ++ |
+ # it is not acutally used in the tabulation.+ |
+ ||
| 408 | ++ |
+ # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.+ |
+ ||
| 409 | +15x | +
+ colvars[colvars == "ci"] <- "lcl"+ |
+ ||
| 410 | ++ | + + | +||
| 411 | +15x | +
+ list(+ |
+ ||
| 412 | +15x | +
+ vars = colvars,+ |
+ ||
| 413 | +15x | +
+ labels = varlabels[vars]+ |
+ ||
| 414 | ++ |
+ )+ |
+ ||
| 415 |
}@@ -143967,14 +146268,14 @@ tern coverage - 90.46% |
| 1 |
- #' Convert `rtable` object to `ggplot` object+ #' Additional Assertions for `checkmate` |
|||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' Additional assertion functions which can be used together with the `checkmate` package. |
|||
| 5 |
- #' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using+ #' @inheritParams checkmate::assert_factor |
|||
| 6 |
- #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored.+ #' @param x (`any`)\cr object to test. |
|||
| 7 |
- #'+ #' @param df (`data.frame`)\cr data set to test. |
|||
| 8 |
- #' @param tbl (`rtable`)\cr a `rtable` object.+ #' @param variables (named `list` of `character`)\cr list of variables to test. |
|||
| 9 |
- #' @param fontsize (`numeric`)\cr font size.+ #' @param include_boundaries (`logical`)\cr whether to include boundaries when testing |
|||
| 10 |
- #' @param colwidths (`vector` of `numeric`)\cr a vector of column widths. Each element's position in+ #' for proportions. |
|||
| 11 |
- #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths+ #' @param na_level (`character`)\cr the string you have been using to represent NA or |
|||
| 12 |
- #' are calculated according to maximum number of characters per column.+ #' missing data. For `NA` values please consider using directly [is.na()] or |
|||
| 13 |
- #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between+ #' similar approaches. |
|||
| 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.+ #' @return Nothing if assertion passes, otherwise prints the error message. |
|||
| 17 |
- #' @return a `ggplot` object.+ #' @name assertions |
|||
| 18 |
- #'+ NULL |
|||
| 19 |
- #' @examples+ |
|||
| 20 |
- #' dta <- data.frame(+ check_list_of_variables <- function(x) {
|
|||
| 21 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ # drop NULL elements in list |
|||
| 22 | -+ | 2369x |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ x <- Filter(Negate(is.null), x) |
|
| 23 |
- #' AVAL = c(9:1, rep(NA, 9))+ |
|||
| 24 | -+ | 2369x |
- #' )+ res <- checkmate::check_list(x, |
|
| 25 | -+ | 2369x |
- #'+ names = "named", |
|
| 26 | -+ | 2369x |
- #' lyt <- basic_table() %>%+ min.len = 1, |
|
| 27 | -+ | 2369x |
- #' split_cols_by(var = "ARM") %>%+ any.missing = FALSE, |
|
| 28 | -+ | 2369x |
- #' split_rows_by(var = "AVISIT") %>%+ types = "character" |
|
| 29 |
- #' analyze_vars(vars = "AVAL")+ ) |
|||
| 30 |
- #'+ # no empty strings allowed |
|||
| 31 | -+ | 2369x |
- #' tbl <- build_table(lyt, df = dta)+ if (isTRUE(res)) {
|
|
| 32 | -+ | 2364x |
- #'+ res <- checkmate::check_character(unlist(x), min.chars = 1) |
|
| 33 |
- #' rtable2gg(tbl)+ } |
|||
| 34 | -+ | 2369x |
- #'+ return(res) |
|
| 35 |
- #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1))+ } |
|||
| 36 |
- #'+ #' @describeIn assertions Checks whether `x` is a valid list of variable names. |
|||
| 37 |
- #' @export+ #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`. |
|||
| 38 |
- rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
+ #' |
|||
| 39 | -5x | +
- mat <- rtables::matrix_form(tbl)+ #' @keywords internal |
||
| 40 | -5x | +
- mat_strings <- formatters::mf_strings(mat)+ assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables) |
||
| 41 | -5x | +
- mat_aligns <- formatters::mf_aligns(mat)+ |
||
| 42 | -5x | +
- mat_indent <- formatters::mf_rinfo(mat)$indent+ check_df_with_variables <- function(df, variables, na_level = NULL) {
|
||
| 43 | -5x | +2110x |
- mat_display <- formatters::mf_display(mat)+ checkmate::assert_data_frame(df) |
|
| 44 | -5x | +2108x |
- nlines_hdr <- formatters::mf_nlheader(mat)+ assert_list_of_variables(variables) |
|
| 45 | -5x | +
- shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x))))+ |
||
| 46 |
-
+ # flag for equal variables and column names |
|||
| 47 | -5x | +2106x |
- tbl_df <- data.frame(mat_strings)+ err_flag <- all(unlist(variables) %in% colnames(df)) |
|
| 48 | -5x | +2106x |
- body_rows <- seq(nlines_hdr + 1, nrow(tbl_df))+ checkmate::assert_flag(err_flag) |
|
| 49 | -5x | +
- mat_aligns <- apply(mat_aligns, 1:2, function(x) if (x == "left") 0 else if (x == "right") 1 else 0.5)+ |
||
| 50 | -+ | 2106x |
-
+ if (isFALSE(err_flag)) {
|
|
| 51 | -+ | 5x |
- # Apply indentation in first column+ vars <- setdiff(unlist(variables), colnames(df)) |
|
| 52 | 5x |
- tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
+ return(paste( |
||
| 53 | -35x | +5x |
- ind_i <- mat_indent[i - nlines_hdr] * 4+ deparse(substitute(df)), |
|
| 54 | -15x | +5x |
- if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1]
+ "does not contain all specified variables as column names. Missing from dataframe:", |
|
| 55 | -+ | 5x |
- })+ paste(vars, collapse = ", ") |
|
| 56 |
-
+ )) |
|||
| 57 |
- # Get column widths+ } |
|||
| 58 | -5x | +
- if (is.null(colwidths)) {
+ # checking if na_level is present and in which column |
||
| 59 | -5x | +2101x |
- colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1+ if (!is.null(na_level)) {
|
|
| 60 | -+ | 9x |
- }+ checkmate::assert_string(na_level) |
|
| 61 | -5x | +9x |
- tot_width <- sum(colwidths) + lbl_col_padding+ res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level))) |
|
| 62 | -+ | 9x |
-
+ if (any(res)) {
|
|
| 63 | -5x | +1x |
- if (length(shared_hdr_rows) > 0) {
+ return(paste0( |
|
| 64 | -4x | +1x |
- tbl_df <- tbl_df[-shared_hdr_rows, ]+ deparse(substitute(df)), " contains explicit na_level (", na_level,
|
|
| 65 | -4x | +1x |
- mat_aligns <- mat_aligns[-shared_hdr_rows, ]+ ") in the following columns: ", paste0(unlist(variables)[res], |
|
| 66 | -+ | 1x |
- }+ collapse = ", " |
|
| 67 |
-
+ ) |
|||
| 68 | -5x | +
- res <- ggplot(data = tbl_df) ++ )) |
||
| 69 | -5x | +
- theme_void() ++ } |
||
| 70 | -5x | +
- scale_x_continuous(limits = c(0, tot_width)) ++ } |
||
| 71 | -5x | +2100x |
- scale_y_continuous(limits = c(0, nrow(mat_strings))) ++ return(TRUE) |
|
| 72 | -5x | +
- annotate(+ } |
||
| 73 | -5x | +
- "segment",+ #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`. |
||
| 74 | -5x | +
- x = 0, xend = tot_width,+ #' Please notice how this produces an error when not all variables are present in the |
||
| 75 | -5x | +
- y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5+ #' data.frame while the opposite is not required. |
||
| 76 |
- )+ #' |
|||
| 77 |
-
+ #' @keywords internal |
|||
| 78 |
- # If header content spans multiple columns, center over these columns+ assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables) |
|||
| 79 | -5x | +
- if (length(shared_hdr_rows) > 0) {
+
|
||
| 80 | -4x | +
- mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ])+ check_valid_factor <- function(x, |
||
| 81 | -4x | +
- for (hr in shared_hdr_rows) {
+ min.levels = 1, # nolint |
||
| 82 | -5x | +
- hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]]+ max.levels = NULL, # nolint |
||
| 83 | -5x | +
- hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr)+ null.ok = TRUE, # nolint |
||
| 84 | -5x | +
- for (idx_hl in seq_len(ncol(hdr_lbls))) {
+ any.missing = TRUE, # nolint |
||
| 85 | -11x | +
- cur_lbl <- tail(hdr_lbls[, idx_hl], 1)+ n.levels = NULL, # nolint |
||
| 86 | -11x | +
- which_cols <- if (hr == 1) {
+ len = NULL) {
|
||
| 87 | -7x | +
- which(mat_strings[hr, ] == hdr_lbls[idx_hl])+ # checks on levels insertion |
||
| 88 | -11x | +894x |
- } else { # for >2 col splits, only print labels for each unique combo of nested columns
+ checkmate::assert_int(min.levels, lower = 1) |
|
| 89 | -4x | +
- which(+ |
||
| 90 | -4x | +
- apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl]))+ # main factor check |
||
| 91 | -+ | 894x |
- )+ res <- checkmate::check_factor(x, |
|
| 92 | -+ | 894x |
- }+ min.levels = min.levels, |
|
| 93 | -11x | +894x |
- line_pos <- c(+ null.ok = null.ok, |
|
| 94 | -11x | +894x |
- sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding,+ max.levels = max.levels, |
|
| 95 | -11x | +894x |
- sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding+ any.missing = any.missing, |
|
| 96 | -+ | 894x |
- )+ n.levels = n.levels |
|
| 97 |
-
+ ) |
|||
| 98 | -11x | +
- res <- res ++ |
||
| 99 | -11x | +
- annotate(+ # no empty strings allowed |
||
| 100 | -11x | +894x |
- "text",+ if (isTRUE(res)) {
|
|
| 101 | -11x | +880x |
- x = mean(line_pos),+ res <- checkmate::check_character(levels(x), min.chars = 1) |
|
| 102 | -11x | +
- y = nrow(mat_strings) + 1 - hr,+ } |
||
| 103 | -11x | +
- label = cur_lbl,+ |
||
| 104 | -11x | +894x |
- size = fontsize / .pt+ return(res) |
|
| 105 |
- ) ++ } |
|||
| 106 | -11x | +
- annotate(+ #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty |
||
| 107 | -11x | +
- "segment",+ #' string levels). Note that `NULL` and `NA` elements are allowed. |
||
| 108 | -11x | +
- x = line_pos[1],+ #' |
||
| 109 | -11x | +
- xend = line_pos[2],+ #' @keywords internal |
||
| 110 | -11x | +
- y = nrow(mat_strings) - hr + 0.5,+ assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor) |
||
| 111 | -11x | +
- yend = nrow(mat_strings) - hr + 0.5+ |
||
| 112 |
- )+ |
|||
| 113 |
- }+ check_df_with_factors <- function(df, |
|||
| 114 |
- }+ variables, |
|||
| 115 |
- }+ min.levels = 1, # nolint |
|||
| 116 |
-
+ max.levels = NULL, # nolint |
|||
| 117 |
- # Add table columns+ any.missing = TRUE, # nolint |
|||
| 118 | -5x | +
- for (i in seq_len(ncol(tbl_df))) {
+ na_level = NULL) {
|
||
| 119 | -32x | +206x |
- res <- res + annotate(+ res <- check_df_with_variables(df, variables, na_level) |
|
| 120 | -32x | +
- "text",+ # checking if all the columns specified by variables are valid factors |
||
| 121 | -32x | +205x |
- x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding,+ if (isTRUE(res)) {
|
|
| 122 | -32x | +
- y = rev(seq_len(nrow(tbl_df))),+ # searching the data.frame with selected columns (variables) as a list |
||
| 123 | -32x | +203x |
- label = tbl_df[, i],+ res <- lapply( |
|
| 124 | -32x | +203x |
- hjust = mat_aligns[, i],+ X = as.list(df)[unlist(variables)], |
|
| 125 | -32x | +203x |
- size = fontsize / .pt+ FUN = check_valid_factor, |
|
| 126 | +203x | +
+ min.levels = min.levels,+ |
+ ||
| 127 | +203x | +
+ max.levels = max.levels,+ |
+ ||
| 128 | +203x | +
+ any.missing = any.missing+ |
+ ||
| 129 |
) |
|||
| 130 | +203x | +
+ res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ |
+ ||
| 131 | +203x | +
+ if (any(res_lo)) {
+ |
+ ||
| 132 | +6x | +
+ return(paste0(+ |
+ ||
| 133 | +6x | +
+ deparse(substitute(df)), " does not contain only factor variables among:",+ |
+ ||
| 134 | +6x | +
+ "\n* Column `", paste0(unlist(variables)[res_lo],+ |
+ ||
| 135 | +6x | +
+ "` of the data.frame -> ", res[res_lo],+ |
+ ||
| 136 | +6x | +
+ collapse = "\n* "+ |
+ ||
| 127 | +137 | ++ |
+ )+ |
+ |
| 138 | ++ |
+ ))+ |
+ ||
| 139 | ++ |
+ } else {
+ |
+ ||
| 140 | +197x | +
+ res <- TRUE+ |
+ ||
| 141 | ++ |
+ }+ |
+ ||
| 142 |
} |
|||
| 143 | +199x | +
+ return(res)+ |
+ ||
| 128 | +144 | ++ |
+ }+ |
+ |
| 145 | ++ |
+ #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`+ |
+ ||
| 146 | ++ |
+ #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ |
+ ||
| 147 | ++ |
+ #' trim `NA` levels out of the vector list itself.+ |
+ ||
| 148 | ++ |
+ #'+ |
+ ||
| 149 | ++ |
+ #' @keywords internal+ |
+ ||
| 150 | ++ |
+ assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)+ |
+ ||
| 151 | ||||
| 152 | ++ |
+ #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.+ |
+ ||
| 153 | ++ |
+ #'+ |
+ ||
| 154 | ++ |
+ #' @keywords internal+ |
+ ||
| 155 | ++ |
+ assert_proportion_value <- function(x, include_boundaries = FALSE) {
+ |
+ ||
| 129 | -5x | +156 | +7476x |
- res+ checkmate::assert_number(x, lower = 0, upper = 1)+ |
+
| 157 | +7464x | +
+ checkmate::assert_flag(include_boundaries)+ |
+ ||
| 158 | +7464x | +
+ if (isFALSE(include_boundaries)) {
+ |
+ ||
| 159 | +3407x | +
+ checkmate::assert_true(x > 0)+ |
+ ||
| 160 | +3405x | +
+ checkmate::assert_true(x < 1) |
||
| 130 | +161 | ++ |
+ }+ |
+ |
| 162 |
}@@ -144883,14 +147408,14 @@ tern coverage - 90.46% |
| 1 |
- #' Helper Functions for Tabulating Binary Response by Subgroup+ #' Difference Test for Two Proportions |
||
| 5 |
- #' Helper functions that tabulate in a data frame statistics such as response rate+ #' Various tests were implemented to test the difference between two proportions. |
||
| 6 |
- #' and odds ratio for population subgroups.+ #' |
||
| 7 |
- #'+ #' @inheritParams argument_convention |
||
| 8 |
- #' @inheritParams argument_convention+ #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used |
||
| 9 |
- #' @inheritParams response_subgroups+ #' to calculate the p-value. |
||
| 10 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("test_proportion_diff")`
|
||
| 11 |
- #'+ #' to see available statistics for this function. |
||
| 12 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' |
||
| 13 |
- #'+ #' @seealso [h_prop_diff_test] |
||
| 14 |
- #' @examples+ #' |
||
| 15 |
- #' library(dplyr)+ #' @name prop_diff_test |
||
| 16 |
- #' library(forcats)+ #' @order 1 |
||
| 17 |
- #'+ NULL |
||
| 18 |
- #' adrs <- tern_ex_adrs+ |
||
| 19 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions. |
||
| 21 |
- #' adrs_f <- adrs %>%+ #' @return |
||
| 22 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label` |
||
| 23 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same. |
||
| 24 |
- #' droplevels() %>%+ #' |
||
| 25 |
- #' mutate(+ #' @keywords internal |
||
| 26 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ s_test_proportion_diff <- function(df, |
||
| 27 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ .var, |
||
| 28 |
- #' rsp = AVALC == "CR"+ .ref_group, |
||
| 29 |
- #' )+ .in_ref_col, |
||
| 30 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ variables = list(strata = NULL), |
||
| 31 |
- #'+ method = c("chisq", "schouten", "fisher", "cmh")) {
|
||
| 32 | -+ | 35x |
- #' @name h_response_subgroups+ method <- match.arg(method) |
| 33 | -+ | 35x |
- NULL+ y <- list(pval = "") |
| 35 | -+ | 35x |
- #' @describeIn h_response_subgroups helper to prepare a data frame of binary responses by arm.+ if (!.in_ref_col) {
|
| 36 | -+ | 35x |
- #'+ assert_df_with_variables(df, list(rsp = .var)) |
| 37 | -+ | 35x |
- #' @return+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
| 38 | -+ | 35x |
- #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`.+ rsp <- factor( |
| 39 | -+ | 35x |
- #'+ c(.ref_group[[.var]], df[[.var]]), |
| 40 | -+ | 35x |
- #' @examples+ levels = c("TRUE", "FALSE")
|
| 41 |
- #' h_proportion_df(+ ) |
||
| 42 | -+ | 35x |
- #' c(TRUE, FALSE, FALSE),+ grp <- factor( |
| 43 | -+ | 35x |
- #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
| 44 | -+ | 35x |
- #' )+ levels = c("ref", "Not-ref")
|
| 45 |
- #'+ ) |
||
| 46 |
- #' @export+ |
||
| 47 | -+ | 35x |
- h_proportion_df <- function(rsp, arm) {
+ if (!is.null(variables$strata) || method == "cmh") {
|
| 48 | -64x | +12x |
- checkmate::assert_logical(rsp)+ strata <- variables$strata |
| 49 | -63x | +12x |
- assert_valid_factor(arm, len = length(rsp))+ checkmate::assert_false(is.null(strata)) |
| 50 | -63x | +12x |
- non_missing_rsp <- !is.na(rsp)+ strata_vars <- stats::setNames(as.list(strata), strata) |
| 51 | -63x | +12x |
- rsp <- rsp[non_missing_rsp]+ assert_df_with_variables(df, strata_vars) |
| 52 | -63x | +12x |
- arm <- arm[non_missing_rsp]+ assert_df_with_variables(.ref_group, strata_vars) |
| 53 | -+ | 12x |
-
+ strata <- c(interaction(.ref_group[strata]), interaction(df[strata])) |
| 54 | -63x | +
- lst_rsp <- split(rsp, arm)+ } |
|
| 55 | -63x | +
- lst_results <- Map(function(x, arm) {
+
|
|
| 56 | -126x | +35x |
- if (length(x) > 0) {
+ tbl <- switch(method, |
| 57 | -124x | +35x |
- s_prop <- s_proportion(df = x)+ cmh = table(grp, rsp, strata), |
| 58 | -124x | +35x |
- data.frame(+ table(grp, rsp) |
| 59 | -124x | +
- arm = arm,+ ) |
|
| 60 | -124x | +
- n = length(x),+ |
|
| 61 | -124x | +35x |
- n_rsp = unname(s_prop$n_prop[1]),+ y$pval <- switch(method, |
| 62 | -124x | +35x |
- prop = unname(s_prop$n_prop[2]),+ chisq = prop_chisq(tbl), |
| 63 | -124x | +35x |
- stringsAsFactors = FALSE+ cmh = prop_cmh(tbl), |
| 64 | -+ | 35x |
- )+ fisher = prop_fisher(tbl), |
| 65 | -+ | 35x |
- } else {
+ schouten = prop_schouten(tbl) |
| 66 | -2x | +
- data.frame(+ ) |
|
| 67 | -2x | +
- arm = arm,+ } |
|
| 68 | -2x | +
- n = 0L,+ |
|
| 69 | -2x | +35x |
- n_rsp = NA,+ y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method)) |
| 70 | -2x | +35x |
- prop = NA,+ y |
| 71 | -2x | +
- stringsAsFactors = FALSE+ } |
|
| 72 |
- )+ |
||
| 73 |
- }+ #' Description of the Difference Test Between Two Proportions |
||
| 74 | -63x | +
- }, lst_rsp, names(lst_rsp))+ #' |
|
| 75 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 76 | -63x | +
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ #' |
|
| 77 | -63x | +
- df$arm <- factor(df$arm, levels = levels(arm))+ #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`. |
|
| 78 | -63x | +
- df+ #' |
|
| 79 |
- }+ #' @inheritParams s_test_proportion_diff |
||
| 80 |
-
+ #' |
||
| 81 |
- #' @describeIn h_response_subgroups summarizes proportion of binary responses by arm and across subgroups+ #' @return `string` describing the test from which the p-value is derived. |
||
| 82 |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ #' |
||
| 83 |
- #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ #' @export |
||
| 84 |
- #' groupings for `subgroups` variables.+ d_test_proportion_diff <- function(method) {
|
||
| 85 | -+ | 49x |
- #'+ checkmate::assert_string(method) |
| 86 | -+ | 49x |
- #' @return+ meth_part <- switch(method, |
| 87 | -+ | 49x |
- #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`,+ "schouten" = "Chi-Squared Test with Schouten Correction", |
| 88 | -+ | 49x |
- #' `var`, `var_label`, and `row_type`.+ "chisq" = "Chi-Squared Test", |
| 89 | -+ | 49x |
- #'+ "cmh" = "Cochran-Mantel-Haenszel Test", |
| 90 | -+ | 49x |
- #' @examples+ "fisher" = "Fisher's Exact Test", |
| 91 | -+ | 49x |
- #' h_proportion_subgroups_df(+ stop(paste(method, "does not have a description")) |
| 92 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ ) |
||
| 93 | -+ | 49x |
- #' data = adrs_f+ paste0("p-value (", meth_part, ")")
|
| 94 |
- #' )+ } |
||
| 95 |
- #'+ |
||
| 96 |
- #' # Define groupings for BMRKR2 levels.+ #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`. |
||
| 97 |
- #' h_proportion_subgroups_df(+ #' |
||
| 98 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' @return |
||
| 99 |
- #' data = adrs_f,+ #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 100 |
- #' groups_lists = list(+ #' |
||
| 101 |
- #' BMRKR2 = list(+ #' @keywords internal |
||
| 102 |
- #' "low" = "LOW",+ a_test_proportion_diff <- make_afun( |
||
| 103 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ s_test_proportion_diff, |
||
| 104 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ .formats = c(pval = "x.xxxx | (<0.0001)"), |
||
| 105 |
- #' )+ .indent_mods = c(pval = 1L) |
||
| 106 |
- #' )+ ) |
||
| 107 |
- #' )+ |
||
| 108 |
- #'+ #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments |
||
| 109 |
- #' @export+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 110 |
- h_proportion_subgroups_df <- function(variables,+ #' |
||
| 111 |
- data,+ #' @return |
||
| 112 |
- groups_lists = list(),+ #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
||
| 113 |
- label_all = "All Patients") {
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 114 | -14x | +
- checkmate::assert_character(variables$rsp)+ #' the statistics from `s_test_proportion_diff()` to the table layout. |
|
| 115 | -14x | +
- checkmate::assert_character(variables$arm)+ #' |
|
| 116 | -14x | +
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ #' @examples |
|
| 117 | -14x | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ #' dta <- data.frame( |
|
| 118 | -14x | +
- assert_df_with_variables(data, variables)+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
|
| 119 | -14x | +
- checkmate::assert_string(label_all)+ #' grp = factor(rep(c("A", "B"), each = 50)),
|
|
| 120 |
-
+ #' strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
|
||
| 121 |
- # Add All Patients.+ #' ) |
||
| 122 | -14x | +
- result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])+ #' |
|
| 123 | -14x | +
- result_all$subgroup <- label_all+ #' # With `rtables` pipelines. |
|
| 124 | -14x | +
- result_all$var <- "ALL"+ #' l <- basic_table() %>% |
|
| 125 | -14x | +
- result_all$var_label <- label_all+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
|
| 126 | -14x | +
- result_all$row_type <- "content"+ #' test_proportion_diff( |
|
| 127 |
-
+ #' vars = "rsp", |
||
| 128 |
- # Add Subgroups.+ #' method = "cmh", variables = list(strata = "strata") |
||
| 129 | -14x | +
- if (is.null(variables$subgroups)) {
+ #' ) |
|
| 130 | -3x | +
- result_all+ #' |
|
| 131 |
- } else {
+ #' build_table(l, df = dta) |
||
| 132 | -11x | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ #' |
|
| 133 |
-
+ #' @export |
||
| 134 | -11x | +
- l_result <- lapply(l_data, function(grp) {
+ #' @order 2 |
|
| 135 | -46x | +
- result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])+ test_proportion_diff <- function(lyt, |
|
| 136 | -46x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ vars, |
|
| 137 | -46x | +
- cbind(result, result_labels)+ variables = list(strata = NULL), |
|
| 138 |
- })+ method = c("chisq", "schouten", "fisher", "cmh"),
|
||
| 139 | -11x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ na_str = default_na_str(), |
|
| 140 | -11x | +
- result_subgroups$row_type <- "analysis"+ nested = TRUE, |
|
| 141 |
-
+ ..., |
||
| 142 | -11x | +
- rbind(+ var_labels = vars, |
|
| 143 | -11x | +
- result_all,+ show_labels = "hidden", |
|
| 144 | -11x | +
- result_subgroups+ table_names = vars, |
|
| 145 |
- )+ .stats = NULL, |
||
| 146 |
- }+ .formats = NULL, |
||
| 147 |
- }+ .labels = NULL, |
||
| 148 |
-
+ .indent_mods = NULL) {
|
||
| 149 | -+ | 6x |
- #' @describeIn h_response_subgroups helper to prepare a data frame with estimates of+ extra_args <- list(variables = variables, method = method, ...) |
| 150 |
- #' the odds ratio between a treatment and a control arm.+ |
||
| 151 | -+ | 6x |
- #'+ afun <- make_afun( |
| 152 | -+ | 6x |
- #' @inheritParams response_subgroups+ a_test_proportion_diff, |
| 153 | -+ | 6x |
- #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.+ .stats = .stats, |
| 154 | -+ | 6x |
- #'+ .formats = .formats, |
| 155 | -+ | 6x |
- #' @return+ .labels = .labels, |
| 156 | -+ | 6x |
- #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and+ .indent_mods = .indent_mods |
| 157 |
- #' optionally `pval` and `pval_label`.+ ) |
||
| 158 | -+ | 6x |
- #'+ analyze( |
| 159 | -+ | 6x |
- #' @examples+ lyt, |
| 160 | -+ | 6x |
- #' # Unstratatified analysis.+ vars, |
| 161 | -+ | 6x |
- #' h_odds_ratio_df(+ afun = afun, |
| 162 | -+ | 6x |
- #' c(TRUE, FALSE, FALSE, TRUE),+ var_labels = var_labels, |
| 163 | -+ | 6x |
- #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ na_str = na_str, |
| 164 | -+ | 6x |
- #' )+ nested = nested, |
| 165 | -+ | 6x |
- #'+ extra_args = extra_args, |
| 166 | -+ | 6x |
- #' # Include p-value.+ show_labels = show_labels, |
| 167 | -+ | 6x |
- #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")+ table_names = table_names |
| 168 |
- #'+ ) |
||
| 169 |
- #' # Stratatified analysis.+ } |
||
| 170 |
- #' h_odds_ratio_df(+ |
||
| 171 |
- #' rsp = adrs_f$rsp,+ #' Helper Functions to Test Proportion Differences |
||
| 172 |
- #' arm = adrs_f$ARM,+ #' |
||
| 173 |
- #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
+ #' Helper functions to implement various tests on the difference between two proportions. |
||
| 174 |
- #' method = "cmh"+ #' |
||
| 175 |
- #' )+ #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns. |
||
| 177 |
- #' @export+ #' @return A p-value. |
||
| 178 |
- h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
+ #' |
||
| 179 | -69x | +
- assert_valid_factor(arm, n.levels = 2, len = length(rsp))+ #' @seealso [prop_diff_test()] for implementation of these helper functions. |
|
| 180 |
-
+ #' |
||
| 181 | -69x | +
- df_rsp <- data.frame(+ #' @name h_prop_diff_test |
|
| 182 | -69x | +
- rsp = rsp,+ NULL |
|
| 183 | -69x | +
- arm = arm+ |
|
| 184 |
- )+ #' @describeIn h_prop_diff_test performs Chi-Squared test. Internally calls [stats::prop.test()]. |
||
| 185 |
-
+ #' |
||
| 186 | -69x | +
- if (!is.null(strata_data)) {
+ #' @keywords internal |
|
| 187 | -11x | +
- strata_var <- interaction(strata_data, drop = TRUE)+ prop_chisq <- function(tbl) {
|
|
| 188 | -11x | +30x |
- strata_name <- "strata"+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 189 | -+ | 30x |
-
+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 190 | -11x | +30x |
- assert_valid_factor(strata_var, len = nrow(df_rsp))+ if (any(colSums(tbl) == 0)) {
|
| 191 | -+ | 2x |
-
+ return(1) |
| 192 | -11x | +
- df_rsp[[strata_name]] <- strata_var+ } |
|
| 193 | -+ | 28x |
- } else {
+ stats::prop.test(tbl, correct = FALSE)$p.value |
| 194 | -58x | +
- strata_name <- NULL+ } |
|
| 195 |
- }+ |
||
| 196 |
-
+ #' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test. Internally calls |
||
| 197 | -69x | +
- l_df <- split(df_rsp, arm)+ #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded. |
|
| 198 |
-
+ #' |
||
| 199 | -69x | +
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response |
|
| 200 |
- # Odds ratio and CI.+ #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension. |
||
| 201 | -67x | +
- result_odds_ratio <- s_odds_ratio(+ #' |
|
| 202 | -67x | +
- df = l_df[[2]],+ #' @keywords internal |
|
| 203 | -67x | +
- .var = "rsp",+ prop_cmh <- function(ary) {
|
|
| 204 | -67x | +16x |
- .ref_group = l_df[[1]],+ checkmate::assert_array(ary) |
| 205 | -67x | +16x |
- .in_ref_col = FALSE,+ checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2) |
| 206 | -67x | +16x |
- .df_row = df_rsp,+ checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3) |
| 207 | -67x | +16x |
- variables = list(arm = "arm", strata = strata_name),+ strata_sizes <- apply(ary, MARGIN = 3, sum) |
| 208 | -67x | +16x |
- conf_level = conf_level+ if (any(strata_sizes < 5)) {
|
| 209 | -+ | 1x |
- )+ warning("<5 data points in some strata. CMH test may be incorrect.")
|
| 210 | -+ | 1x |
-
+ ary <- ary[, , strata_sizes > 1] |
| 211 | -67x | +
- df <- data.frame(+ } |
|
| 212 |
- # Dummy column needed downstream to create a nested header.+ |
||
| 213 | -67x | +16x |
- arm = " ",+ stats::mantelhaen.test(ary, correct = FALSE)$p.value |
| 214 | -67x | +
- n_tot = unname(result_odds_ratio$n_tot["n_tot"]),+ } |
|
| 215 | -67x | +
- or = unname(result_odds_ratio$or_ci["est"]),+ |
|
| 216 | -67x | +
- lcl = unname(result_odds_ratio$or_ci["lcl"]),+ #' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten correction. |
|
| 217 | -67x | +
- ucl = unname(result_odds_ratio$or_ci["ucl"]),+ #' |
|
| 218 | -67x | +
- conf_level = conf_level,+ #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
|
|
| 219 | -67x | +
- stringsAsFactors = FALSE+ #' |
|
| 220 |
- )+ #' @keywords internal |
||
| 221 |
-
+ prop_schouten <- function(tbl) {
|
||
| 222 | -67x | +100x |
- if (!is.null(method)) {
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 223 | -+ | 100x |
- # Test for difference.+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 224 | -34x | +100x |
- result_test <- s_test_proportion_diff(+ if (any(colSums(tbl) == 0)) {
|
| 225 | -34x | +1x |
- df = l_df[[2]],+ return(1) |
| 226 | -34x | +
- .var = "rsp",+ } |
|
| 227 | -34x | +
- .ref_group = l_df[[1]],+ |
|
| 228 | -34x | +99x |
- .in_ref_col = FALSE,+ n <- sum(tbl) |
| 229 | -34x | +99x |
- variables = list(strata = strata_name),+ n1 <- sum(tbl[1, ]) |
| 230 | -34x | +99x |
- method = method+ n2 <- sum(tbl[2, ]) |
| 231 |
- )+ |
||
| 232 | -+ | 99x |
-
+ ad <- diag(tbl) |
| 233 | -34x | +99x |
- df$pval <- as.numeric(result_test$pval)+ bc <- diag(apply(tbl, 2, rev)) |
| 234 | -34x | +99x |
- df$pval_label <- obj_label(result_test$pval)+ ac <- tbl[, 1] |
| 235 | -+ | 99x |
- }+ bd <- tbl[, 2] |
| 237 | -+ | 99x |
- # In those cases cannot go through the model so will obtain n_tot from data.+ t_schouten <- (n - 1) * |
| 238 | -+ | 99x |
- } else if (+ (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 / |
| 239 | -2x | +99x |
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ (n1 * n2 * sum(ac) * sum(bd)) |
| 240 | -2x | +
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ |
|
| 241 | -+ | 99x |
- ) {
+ 1 - stats::pchisq(t_schouten, df = 1) |
| 242 | -2x | +
- df <- data.frame(+ } |
|
| 243 |
- # Dummy column needed downstream to create a nested header.+ |
||
| 244 | -2x | +
- arm = " ",+ #' @describeIn h_prop_diff_test performs the Fisher's exact test. Internally calls [stats::fisher.test()]. |
|
| 245 | -2x | +
- n_tot = sum(stats::complete.cases(df_rsp)),+ #' |
|
| 246 | -2x | +
- or = NA,+ #' @keywords internal |
|
| 247 | -2x | +
- lcl = NA,+ prop_fisher <- function(tbl) {
|
|
| 248 | 2x |
- ucl = NA,+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
|
| 249 | 2x |
- conf_level = conf_level,+ tbl <- tbl[, c("TRUE", "FALSE")]
|
|
| 250 | 2x |
- stringsAsFactors = FALSE+ stats::fisher.test(tbl)$p.value |
|
| 251 |
- )+ } |
||
| 252 | -2x | +
| 1 | +
- if (!is.null(method)) {
+ #' Patient Counts with Abnormal Range Values by Baseline Status |
|||
| 253 | -2x | +|||
| 2 | +
- df$pval <- NA+ #' |
|||
| 254 | -2x | +|||
| 3 | +
- df$pval_label <- NA+ #' @description `r lifecycle::badge("stable")`
|
|||
| 255 | +4 |
- }+ #' |
||
| 256 | +5 |
- } else {
+ #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`), and additional |
||
| 257 | -! | +|||
| 6 | +
- df <- data.frame(+ #' analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or `factor`). For each |
|||
| 258 | +7 |
- # Dummy column needed downstream to create a nested header.+ #' direction specified in `abnormal` (e.g. high or low) we condition on baseline range result and count |
||
| 259 | -! | +|||
| 8 | +
- arm = " ",+ #' patients in the numerator and denominator as follows: |
|||
| 260 | -! | +|||
| 9 | +
- n_tot = 0L,+ #' * `Not <Abnormal>` |
|||
| 261 | -! | +|||
| 10 | +
- or = NA,+ #' * `denom`: the number of patients without abnormality at baseline (excluding those with missing baseline) |
|||
| 262 | -! | +|||
| 11 | +
- lcl = NA,+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline |
|||
| 263 | -! | +|||
| 12 | +
- ucl = NA,+ #' * `<Abnormal>` |
|||
| 264 | -! | +|||
| 13 | +
- conf_level = conf_level,+ #' * `denom`: the number of patients with abnormality at baseline |
|||
| 265 | -! | +|||
| 14 | +
- stringsAsFactors = FALSE+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline |
|||
| 266 | +15 |
- )+ #' * `Total` |
||
| 267 | +16 |
-
+ #' * `denom`: the number of patients with at least one valid measurement post-baseline |
||
| 268 | -! | +|||
| 17 | +
- if (!is.null(method)) {
+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline |
|||
| 269 | -! | +|||
| 18 | +
- df$pval <- NA+ #' |
|||
| 270 | -! | +|||
| 19 | +
- df$pval_label <- NA+ #' @inheritParams argument_convention |
|||
| 271 | +20 |
- }+ #' @param abnormal (`character`)\cr identifying the abnormal range level(s) in `.var`. |
||
| 272 | +21 |
- }+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_baseline")`
|
||
| 273 | +22 |
-
+ #' to see available statistics for this function. |
||
| 274 | -69x | +|||
| 23 | +
- df+ #' |
|||
| 275 | +24 |
- }+ #' @note |
||
| 276 | +25 |
-
+ #' * `df` should be filtered to include only post-baseline records. |
||
| 277 | +26 |
- #' @describeIn h_response_subgroups summarizes estimates of the odds ratio between a treatment and a control+ #' * If the baseline variable or analysis variable contains `NA`, it is expected that `NA` has been |
||
| 278 | +27 |
- #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in+ #' conveyed to `na_level` appropriately beforehand with [df_explicit_na()] or [explicit_na()]. |
||
| 279 | +28 |
- #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`+ #' |
||
| 280 | +29 |
- #' and `strat`. `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' @seealso Relevant description function [d_count_abnormal_by_baseline()]. |
||
| 281 | +30 |
#' |
||
| 282 | +31 |
- #' @return+ #' @name abnormal_by_baseline |
||
| 283 | +32 |
- #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`,+ #' @order 1 |
||
| 284 | +33 |
- #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`.+ NULL |
||
| 285 | +34 |
- #'+ |
||
| 286 | +35 |
- #' @examples+ #' Description Function for [s_count_abnormal_by_baseline()] |
||
| 287 | +36 |
- #' # Unstratified analysis.+ #' |
||
| 288 | +37 |
- #' h_odds_ratio_subgroups_df(+ #' @description `r lifecycle::badge("stable")`
|
||
| 289 | +38 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' |
||
| 290 | +39 |
- #' data = adrs_f+ #' Description function that produces the labels for [s_count_abnormal_by_baseline()]. |
||
| 291 | +40 |
- #' )+ #' |
||
| 292 | +41 |
- #'+ #' @inheritParams abnormal_by_baseline |
||
| 293 | +42 |
- #' # Stratified analysis.+ #' |
||
| 294 | +43 |
- #' h_odds_ratio_subgroups_df(+ #' @return Abnormal category labels for [s_count_abnormal_by_baseline()]. |
||
| 295 | +44 |
- #' variables = list(+ #' |
||
| 296 | +45 |
- #' rsp = "rsp",+ #' @examples |
||
| 297 | +46 |
- #' arm = "ARM",+ #' d_count_abnormal_by_baseline("LOW")
|
||
| 298 | +47 |
- #' subgroups = c("SEX", "BMRKR2"),
+ #' |
||
| 299 | +48 |
- #' strat = c("STRATA1", "STRATA2")
+ #' @export |
||
| 300 | +49 |
- #' ),+ d_count_abnormal_by_baseline <- function(abnormal) {
|
||
| 301 | -+ | |||
| 50 | +7x |
- #' data = adrs_f+ not_abn_name <- paste("Not", tolower(abnormal))
+ |
+ ||
| 51 | +7x | +
+ abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))+ |
+ ||
| 52 | +7x | +
+ total_name <- "Total" |
||
| 302 | +53 |
- #' )+ + |
+ ||
| 54 | +7x | +
+ list(+ |
+ ||
| 55 | +7x | +
+ not_abnormal = not_abn_name,+ |
+ ||
| 56 | +7x | +
+ abnormal = abn_name,+ |
+ ||
| 57 | +7x | +
+ total = total_name |
||
| 303 | +58 |
- #'+ ) |
||
| 304 | +59 |
- #' # Define groupings of BMRKR2 levels.+ } |
||
| 305 | +60 |
- #' h_odds_ratio_subgroups_df(+ |
||
| 306 | +61 |
- #' variables = list(+ #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level. |
||
| 307 | +62 |
- #' rsp = "rsp",+ #' |
||
| 308 | +63 |
- #' arm = "ARM",+ #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with |
||
| 309 | +64 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' [df_explicit_na()]). The default is `"<Missing>"`. |
||
| 310 | +65 |
- #' ),+ #' |
||
| 311 | +66 |
- #' data = adrs_f,+ #' @return |
||
| 312 | +67 |
- #' groups_lists = list(+ #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements: |
||
| 313 | +68 |
- #' BMRKR2 = list(+ #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts. |
||
| 314 | +69 |
- #' "low" = "LOW",+ #' |
||
| 315 | +70 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' @keywords internal |
||
| 316 | +71 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ s_count_abnormal_by_baseline <- function(df, |
||
| 317 | +72 |
- #' )+ .var, |
||
| 318 | +73 |
- #' )+ abnormal, |
||
| 319 | +74 |
- #' )+ na_level = lifecycle::deprecated(), |
||
| 320 | +75 |
- #'+ na_str = "<Missing>", |
||
| 321 | +76 |
- #' @export+ variables = list(id = "USUBJID", baseline = "BNRIND")) {
|
||
| 322 | -+ | |||
| 77 | +5x |
- h_odds_ratio_subgroups_df <- function(variables,+ if (lifecycle::is_present(na_level)) {
|
||
| 323 | -+ | |||
| 78 | +! |
- data,+ lifecycle::deprecate_warn("0.9.1", "s_count_abnormal_by_baseline(na_level)", "s_count_abnormal_by_baseline(na_str)")
|
||
| 324 | -+ | |||
| 79 | +! |
- groups_lists = list(),+ na_str <- na_level |
||
| 325 | +80 |
- conf_level = 0.95,+ } |
||
| 326 | +81 |
- method = NULL,+ |
||
| 327 | -+ | |||
| 82 | +5x |
- label_all = "All Patients") {
+ checkmate::assert_string(.var) |
||
| 328 | -15x | +83 | +5x |
- checkmate::assert_character(variables$rsp)+ checkmate::assert_string(abnormal) |
| 329 | -15x | +84 | +5x |
- checkmate::assert_character(variables$arm)+ checkmate::assert_string(na_str) |
| 330 | -15x | +85 | +5x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ assert_df_with_variables(df, c(range = .var, variables)) |
| 331 | -15x | +86 | +5x |
- checkmate::assert_character(variables$strat, null.ok = TRUE)+ checkmate::assert_subset(names(variables), c("id", "baseline"))
|
| 332 | -15x | +87 | +5x |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 333 | -15x | +88 | +5x |
- assert_df_with_variables(data, variables)+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
| 334 | -15x | +89 | +5x |
- checkmate::assert_string(label_all)+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 335 | +90 | |||
| 91 | ++ |
+ # If input is passed as character, changed to factor+ |
+ ||
| 336 | -15x | +92 | +5x |
- strata_data <- if (is.null(variables$strat)) {
+ df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str) |
| 337 | -13x | +93 | +5x |
- NULL+ df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str) |
| 338 | +94 |
- } else {
+
|
||
| 339 | -2x | +95 | +5x |
- data[, variables$strat, drop = FALSE]+ assert_valid_factor(df[[.var]], any.missing = FALSE) |
| 340 | -+ | |||
| 96 | +4x |
- }+ assert_valid_factor(df[[variables$baseline]], any.missing = FALSE) |
||
| 341 | +97 | |||
| 342 | +98 |
- # Add All Patients.+ # Keep only records with valid analysis value. |
||
| 343 | -15x | +99 | +3x |
- result_all <- h_odds_ratio_df(+ df <- df[df[[.var]] != na_str, ]+ |
+
| 100 | ++ | + | ||
| 344 | -15x | +101 | +3x |
- rsp = data[[variables$rsp]],+ anl <- data.frame( |
| 345 | -15x | +102 | +3x |
- arm = data[[variables$arm]],+ id = df[[variables$id]], |
| 346 | -15x | +103 | +3x |
- strata_data = strata_data,+ var = df[[.var]], |
| 347 | -15x | +104 | +3x |
- conf_level = conf_level,+ baseline = df[[variables$baseline]], |
| 348 | -15x | +105 | +3x |
- method = method+ stringsAsFactors = FALSE |
| 349 | +106 |
) |
||
| 350 | -15x | -
- result_all$subgroup <- label_all- |
- ||
| 351 | -15x | +|||
| 107 | +
- result_all$var <- "ALL"+ |
|||
| 352 | -15x | +|||
| 108 | +
- result_all$var_label <- label_all+ # Total: |
|||
| 353 | -15x | +|||
| 109 | +
- result_all$row_type <- "content"+ # - Patients in denominator: have at least one valid measurement post-baseline. |
|||
| 354 | +110 |
-
+ # - Patients in numerator: have at least one abnormality. |
||
| 355 | -15x | +111 | +3x |
- if (is.null(variables$subgroups)) {
+ total_denom <- length(unique(anl$id)) |
| 356 | +112 | 3x |
- result_all+ total_num <- length(unique(anl$id[anl$var == abnormal])) |
|
| 357 | +113 |
- } else {
- |
- ||
| 358 | -12x | -
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
||
| 359 | +114 | - - | -||
| 360 | -12x | -
- l_result <- lapply(l_data, function(grp) {
+ # Baseline NA records are counted only in total rows. |
||
| 361 | -50x | +115 | +3x |
- grp_strata_data <- if (is.null(variables$strat)) {
+ anl <- anl[anl$baseline != na_str, ] |
| 362 | -42x | +|||
| 116 | +
- NULL+ |
|||
| 363 | +117 |
- } else {
+ # Abnormal: |
||
| 364 | -8x | +|||
| 118 | +
- grp$df[, variables$strat, drop = FALSE]+ # - Patients in denominator: have abnormality at baseline. |
|||
| 365 | +119 |
- }+ # - Patients in numerator: have abnormality at baseline AND |
||
| 366 | +120 |
-
+ # have at least one abnormality post-baseline. |
||
| 367 | -50x | +121 | +3x |
- result <- h_odds_ratio_df(+ abn_denom <- length(unique(anl$id[anl$baseline == abnormal])) |
| 368 | -50x | +122 | +3x |
- rsp = grp$df[[variables$rsp]],+ abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal])) |
| 369 | -50x | +|||
| 123 | +
- arm = grp$df[[variables$arm]],+ |
|||
| 370 | -50x | +|||
| 124 | +
- strata_data = grp_strata_data,+ # Not abnormal: |
|||
| 371 | -50x | +|||
| 125 | +
- conf_level = conf_level,+ # - Patients in denominator: do not have abnormality at baseline. |
|||
| 372 | -50x | +|||
| 126 | +
- method = method+ # - Patients in numerator: do not have abnormality at baseline AND |
|||
| 373 | +127 |
- )+ # have at least one abnormality post-baseline. |
||
| 374 | -50x | +128 | +3x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal])) |
| 375 | -50x | -
- cbind(result, result_labels)- |
- ||
| 376 | -+ | 129 | +3x |
- })+ not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal])) |
| 377 | +130 | |||
| 378 | -12x | +131 | +3x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ labels <- d_count_abnormal_by_baseline(abnormal) |
| 379 | -12x | -
- result_subgroups$row_type <- "analysis"- |
- ||
| 380 | -+ | 132 | +3x |
-
+ list(fraction = list( |
| 381 | -12x | +133 | +3x |
- rbind(+ not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal), |
| 382 | -12x | +134 | +3x |
- result_all,+ abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal), |
| 383 | -12x | +135 | +3x |
- result_subgroups+ total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total) |
| 384 | +136 |
- )+ )) |
||
| 385 | +137 |
- }+ } |
||
| 386 | +138 |
- }+ |
| 1 | +139 |
- #' Count the Number of Patients with a Particular Event+ #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun` |
||
| 2 | +140 |
- #'+ #' in `count_abnormal_by_baseline()`. |
||
| 3 | +141 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 | +142 |
- #'+ #' @return |
||
| 5 | +143 |
- #' The primary analysis variable `.var` denotes the unique patient identifier.+ #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 6 | +144 |
#' |
||
| 7 | +145 |
- #' @inheritParams argument_convention+ #' @keywords internal |
||
| 8 | +146 |
- #' @param filters (`character`)\cr a character vector specifying the column names and flag variables+ a_count_abnormal_by_baseline <- make_afun( |
||
| 9 | +147 |
- #' to be used for counting the number of unique identifiers satisfying such conditions.+ s_count_abnormal_by_baseline, |
||
| 10 | +148 |
- #' Multiple column names and flags are accepted in this format+ .formats = c(fraction = format_fraction) |
||
| 11 | +149 |
- #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
+ ) |
||
| 12 | +150 |
- #' Note that only equality is being accepted as condition.+ |
||
| 13 | +151 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_event")`
+ #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments |
||
| 14 | +152 |
- #' to see available statistics for this function.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 15 | +153 |
#' |
||
| 16 | +154 |
- #' @seealso [count_patients_with_flags]+ #' @return |
||
| 17 | +155 |
- #'+ #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions, |
||
| 18 | +156 |
- #' @name count_patients_with_event+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 19 | +157 |
- #' @order 1+ #' the statistics from `s_count_abnormal_by_baseline()` to the table layout. |
||
| 20 | +158 |
- NULL+ #' |
||
| 21 | +159 |
-
+ #' @examples |
||
| 22 | +160 |
- #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which+ #' df <- data.frame( |
||
| 23 | +161 |
- #' the defined event has occurred.+ #' USUBJID = as.character(c(1:6)), |
||
| 24 | +162 |
- #'+ #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
|
||
| 25 | +163 |
- #' @inheritParams analyze_variables+ #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
|
||
| 26 | +164 |
- #' @param .var (`character`)\cr name of the column that contains the unique identifier.+ #' ) |
||
| 27 | +165 |
- #'+ #' df <- df_explicit_na(df) |
||
| 28 | +166 |
- #' @return+ #' |
||
| 29 | +167 |
- #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event.+ #' # Layout creating function. |
||
| 30 | +168 |
- #'+ #' basic_table() %>% |
||
| 31 | +169 |
- #' @examples+ #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>% |
||
| 32 | +170 |
- #' # `s_count_patients_with_event()`+ #' build_table(df) |
||
| 33 | +171 |
#' |
||
| 34 | +172 |
- #' s_count_patients_with_event(+ #' # Passing of statistics function and formatting arguments. |
||
| 35 | +173 |
- #' tern_ex_adae,+ #' df2 <- data.frame( |
||
| 36 | +174 |
- #' .var = "SUBJID",+ #' ID = as.character(c(1, 2, 3, 4)), |
||
| 37 | +175 |
- #' filters = c("TRTEMFL" = "Y")
+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 38 | +176 |
- #' )+ #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
|
||
| 39 | +177 |
- #'+ #' ) |
||
| 40 | +178 |
- #' s_count_patients_with_event(+ #' |
||
| 41 | +179 |
- #' tern_ex_adae,+ #' basic_table() %>% |
||
| 42 | +180 |
- #' .var = "SUBJID",+ #' count_abnormal_by_baseline( |
||
| 43 | +181 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
+ #' var = "RANGE", |
||
| 44 | +182 |
- #' )+ #' abnormal = c(Low = "LOW"), |
||
| 45 | +183 |
- #'+ #' variables = list(id = "ID", baseline = "BLRANGE"), |
||
| 46 | +184 |
- #' s_count_patients_with_event(+ #' .formats = c(fraction = "xx / xx"), |
||
| 47 | +185 |
- #' tern_ex_adae,+ #' .indent_mods = c(fraction = 2L) |
||
| 48 | +186 |
- #' .var = "SUBJID",+ #' ) %>% |
||
| 49 | +187 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ #' build_table(df2) |
||
| 50 | +188 |
- #' denom = "N_col",+ #' |
||
| 51 | +189 |
- #' .N_col = 456+ #' @export |
||
| 52 | +190 |
- #' )+ #' @order 2 |
||
| 53 | +191 |
- #'+ count_abnormal_by_baseline <- function(lyt, |
||
| 54 | +192 |
- #' @export+ var, |
||
| 55 | +193 |
- s_count_patients_with_event <- function(df,+ abnormal, |
||
| 56 | +194 |
- .var,+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 57 | +195 |
- filters,+ na_str = "<Missing>", |
||
| 58 | +196 |
- .N_col, # nolint+ nested = TRUE, |
||
| 59 | +197 |
- .N_row, # nolint+ ..., |
||
| 60 | +198 |
- denom = c("n", "N_row", "N_col")) {
- |
- ||
| 61 | -30x | -
- col_names <- names(filters)+ table_names = abnormal, |
||
| 62 | -30x | +|||
| 199 | +
- filter_values <- filters+ .stats = NULL, |
|||
| 63 | +200 |
-
+ .formats = NULL, |
||
| 64 | -30x | +|||
| 201 | +
- checkmate::assert_subset(col_names, colnames(df))+ .labels = NULL, |
|||
| 65 | +202 |
-
+ .indent_mods = NULL) {
|
||
| 66 | -30x | +203 | +2x |
- temp <- Map(+ checkmate::assert_character(abnormal, len = length(table_names), names = "named") |
| 67 | -30x | +204 | +2x |
- function(x, y) which(df[[x]] == y),+ checkmate::assert_string(var) |
| 68 | -30x | +|||
| 205 | +
- col_names,+ |
|||
| 69 | -30x | +206 | +2x |
- filter_values+ extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...) |
| 70 | +207 |
- )- |
- ||
| 71 | -30x | -
- position_satisfy_filters <- Reduce(intersect, temp)+ |
||
| 72 | -30x | +208 | +2x |
- id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]]))+ afun <- make_afun( |
| 73 | -30x | +209 | +2x |
- result <- s_count_values(+ a_count_abnormal_by_baseline, |
| 74 | -30x | +210 | +2x |
- as.character(unique(df[[.var]])),+ .stats = .stats, |
| 75 | -30x | +211 | +2x |
- id_satisfy_filters,+ .formats = .formats, |
| 76 | -30x | +212 | +2x |
- denom = denom,+ .labels = .labels, |
| 77 | -30x | +213 | +2x |
- .N_col = .N_col,+ .indent_mods = .indent_mods, |
| 78 | -30x | +214 | +2x |
- .N_row = .N_row+ .ungroup_stats = "fraction" |
| 79 | +215 |
) |
||
| 80 | -30x | +216 | +2x |
- result+ for (i in seq_along(abnormal)) {
|
| 81 | -+ | |||
| 217 | +4x |
- }+ extra_args[["abnormal"]] <- abnormal[i] |
||
| 82 | +218 | |||
| 83 | -- |
- #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun`- |
- ||
| 84 | -+ | |||
| 219 | +4x |
- #' in `count_patients_with_event()`.+ lyt <- analyze( |
||
| 85 | -+ | |||
| 220 | +4x |
- #'+ lyt = lyt, |
||
| 86 | -+ | |||
| 221 | +4x |
- #' @return+ vars = var, |
||
| 87 | -+ | |||
| 222 | +4x |
- #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()].+ var_labels = names(abnormal[i]), |
||
| 88 | -+ | |||
| 223 | +4x |
- #'+ afun = afun, |
||
| 89 | -+ | |||
| 224 | +4x |
- #' @examples+ na_str = na_str, |
||
| 90 | -+ | |||
| 225 | +4x |
- #' # `a_count_patients_with_event()`+ nested = nested, |
||
| 91 | -+ | |||
| 226 | +4x |
- #'+ table_names = table_names[i], |
||
| 92 | -+ | |||
| 227 | +4x |
- #' a_count_patients_with_event(+ extra_args = extra_args, |
||
| 93 | -+ | |||
| 228 | +4x |
- #' tern_ex_adae,+ show_labels = "visible" |
||
| 94 | +229 |
- #' .var = "SUBJID",+ ) |
||
| 95 | +230 |
- #' filters = c("TRTEMFL" = "Y"),
+ } |
||
| 96 | -+ | |||
| 231 | +2x |
- #' .N_col = 100,+ lyt |
||
| 97 | +232 |
- #' .N_row = 100+ } |
| 98 | +1 |
- #' )+ #' Helper Functions for Tabulating Biomarker Effects on Survival by Subgroup |
||
| 99 | +2 |
#' |
||
| 100 | -- |
- #' @export- |
- ||
| 101 | -- |
- a_count_patients_with_event <- make_afun(- |
- ||
| 102 | -- |
- s_count_patients_with_event,- |
- ||
| 103 | -- |
- .formats = c(count_fraction = format_count_fraction_fixed_dp)- |
- ||
| 104 | -- |
- )- |
- ||
| 105 | -- | - - | -||
| 106 | -- |
- #' @describeIn count_patients_with_event Layout-creating function which can take statistics function- |
- ||
| 107 | +3 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 108 | +4 |
#' |
||
| 109 | -- |
- #' @return- |
- ||
| 110 | +5 |
- #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions,+ #' Helper functions which are documented here separately to not confuse the user |
||
| 111 | +6 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' when reading about the user-facing functions. |
||
| 112 | +7 |
- #' the statistics from `s_count_patients_with_event()` to the table layout.+ #' |
||
| 113 | +8 |
- #'+ #' @inheritParams survival_biomarkers_subgroups |
||
| 114 | +9 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 115 | +10 |
- #' # `count_patients_with_event()`+ #' @inheritParams fit_coxreg_multivar |
||
| 116 | +11 |
#' |
||
| 117 | +12 |
- #' lyt <- basic_table() %>%+ #' @examples |
||
| 118 | +13 |
- #' split_cols_by("ARM") %>%
+ #' library(dplyr) |
||
| 119 | +14 |
- #' add_colcounts() %>%+ #' library(forcats) |
||
| 120 | +15 |
- #' count_values(+ #' |
||
| 121 | +16 |
- #' "STUDYID",+ #' adtte <- tern_ex_adtte |
||
| 122 | +17 |
- #' values = "AB12345",+ #' |
||
| 123 | +18 |
- #' .stats = "count",+ #' # Save variable labels before data processing steps. |
||
| 124 | +19 |
- #' .labels = c(count = "Total AEs")+ #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE) |
||
| 125 | +20 |
- #' ) %>%+ #' |
||
| 126 | +21 |
- #' count_patients_with_event(+ #' adtte_f <- adtte %>% |
||
| 127 | +22 |
- #' "SUBJID",+ #' filter(PARAMCD == "OS") %>% |
||
| 128 | +23 |
- #' filters = c("TRTEMFL" = "Y"),
+ #' mutate( |
||
| 129 | +24 |
- #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"),+ #' AVALU = as.character(AVALU), |
||
| 130 | +25 |
- #' table_names = "tbl_all"+ #' is_event = CNSR == 0 |
||
| 131 | +26 |
- #' ) %>%+ #' ) |
||
| 132 | +27 |
- #' count_patients_with_event(+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
||
| 133 | +28 |
- #' "SUBJID",+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 134 | +29 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ #' |
||
| 135 | +30 |
- #' .labels = c(count_fraction = "Total number of patients with fatal AEs"),+ #' @name h_survival_biomarkers_subgroups |
||
| 136 | +31 |
- #' table_names = "tbl_fatal"+ NULL |
||
| 137 | +32 |
- #' ) %>%+ |
||
| 138 | +33 |
- #' count_patients_with_event(+ #' @describeIn h_survival_biomarkers_subgroups helps with converting the "survival" function variable list |
||
| 139 | +34 |
- #' "SUBJID",+ #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable |
||
| 140 | +35 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
+ #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`. |
||
| 141 | +36 |
- #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"),+ #' |
||
| 142 | +37 |
- #' .indent_mods = c(count_fraction = 2L),+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
||
| 143 | +38 |
- #' table_names = "tbl_rel_fatal"+ #' |
||
| 144 | +39 |
- #' )+ #' @return |
||
| 145 | +40 |
- #'+ #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`, |
||
| 146 | +41 |
- #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl)+ #' `covariates`, and `strata`. |
||
| 147 | +42 |
#' |
||
| 148 | +43 |
- #' @export+ #' @examples |
||
| 149 | +44 |
- #' @order 2+ #' # This is how the variable list is converted internally. |
||
| 150 | +45 |
- count_patients_with_event <- function(lyt,+ #' h_surv_to_coxreg_variables( |
||
| 151 | +46 |
- vars,+ #' variables = list( |
||
| 152 | +47 |
- filters,+ #' tte = "AVAL", |
||
| 153 | +48 |
- riskdiff = FALSE,+ #' is_event = "EVNT", |
||
| 154 | +49 |
- na_str = default_na_str(),+ #' covariates = c("A", "B"),
|
||
| 155 | +50 |
- nested = TRUE,+ #' strata = "D" |
||
| 156 | +51 |
- ...,+ #' ), |
||
| 157 | +52 |
- table_names = vars,+ #' biomarker = "AGE" |
||
| 158 | +53 |
- .stats = "count_fraction",+ #' ) |
||
| 159 | +54 |
- .formats = NULL,+ #' |
||
| 160 | +55 |
- .labels = NULL,+ #' @export |
||
| 161 | +56 |
- .indent_mods = NULL) {
+ h_surv_to_coxreg_variables <- function(variables, biomarker) {
|
||
| 162 | -6x | +57 | +53x |
- checkmate::assert_flag(riskdiff)+ checkmate::assert_list(variables) |
| 163 | -+ | |||
| 58 | +53x |
-
+ checkmate::assert_string(variables$tte) |
||
| 164 | -6x | +59 | +53x |
- s_args <- list(filters = filters, ...)+ checkmate::assert_string(variables$is_event) |
| 165 | -+ | |||
| 60 | +53x |
-
+ checkmate::assert_string(biomarker) |
||
| 166 | -6x | +61 | +53x |
- afun <- make_afun(+ list( |
| 167 | -6x | +62 | +53x |
- a_count_patients_with_event,+ time = variables$tte, |
| 168 | -6x | +63 | +53x |
- .stats = .stats,+ event = variables$is_event, |
| 169 | -6x | +64 | +53x |
- .formats = .formats,+ arm = biomarker, |
| 170 | -6x | +65 | +53x |
- .labels = .labels,+ covariates = variables$covariates, |
| 171 | -6x | +66 | +53x |
- .indent_mods = .indent_mods+ strata = variables$strata |
| 172 | +67 |
) |
||
| 173 | +68 | - - | -||
| 174 | -6x | -
- extra_args <- if (isFALSE(riskdiff)) {
+ } |
||
| 175 | -5x | +|||
| 69 | +
- s_args+ |
|||
| 176 | +70 |
- } else {
+ #' @describeIn h_survival_biomarkers_subgroups prepares estimates for number of events, patients and median survival |
||
| 177 | -1x | +|||
| 71 | +
- list(+ #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers |
|||
| 178 | -1x | +|||
| 72 | +
- afun = list("s_count_patients_with_event" = afun),
+ #' in a given single data set. |
|||
| 179 | -1x | +|||
| 73 | +
- .stats = .stats,+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
|||
| 180 | -1x | +|||
| 74 | +
- .indent_mods = .indent_mods,+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strata`. |
|||
| 181 | -1x | +|||
| 75 | +
- s_args = s_args+ #' |
|||
| 182 | +76 |
- )+ #' @return |
||
| 183 | +77 |
- }+ #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
||
| 184 | +78 |
-
+ #' |
||
| 185 | -6x | +|||
| 79 | +
- analyze(+ #' @examples |
|||
| 186 | -6x | +|||
| 80 | +
- lyt,+ #' # For a single population, estimate separately the effects |
|||
| 187 | -6x | +|||
| 81 | +
- vars,+ #' # of two biomarkers. |
|||
| 188 | -6x | +|||
| 82 | +
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ #' df <- h_coxreg_mult_cont_df( |
|||
| 189 | -6x | +|||
| 83 | +
- na_str = na_str,+ #' variables = list( |
|||
| 190 | -6x | +|||
| 84 | +
- nested = nested,+ #' tte = "AVAL", |
|||
| 191 | -6x | +|||
| 85 | +
- extra_args = extra_args,+ #' is_event = "is_event", |
|||
| 192 | -6x | +|||
| 86 | +
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 193 | -6x | +|||
| 87 | +
- table_names = table_names+ #' covariates = "SEX", |
|||
| 194 | +88 |
- )+ #' strata = c("STRATA1", "STRATA2")
|
||
| 195 | +89 |
- }+ #' ), |
| 1 | +90 |
- #' `rtables` Access Helper Functions+ #' data = adtte_f |
||
| 2 | +91 |
- #'+ #' ) |
||
| 3 | +92 |
- #' @description `r lifecycle::badge("stable")`
+ #' df |
||
| 4 | +93 |
#' |
||
| 5 | +94 |
- #' These are a couple of functions that help with accessing the data in `rtables` objects.+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
||
| 6 | +95 |
- #' Currently these work for occurrence tables, which are defined as having a count as the first+ #' h_coxreg_mult_cont_df( |
||
| 7 | +96 |
- #' element and a fraction as the second element in each cell.+ #' variables = list( |
||
| 8 | +97 |
- #'+ #' tte = "AVAL", |
||
| 9 | +98 |
- #' @seealso [prune_occurrences] for usage of these functions.+ #' is_event = "is_event", |
||
| 10 | +99 |
- #'+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 11 | +100 |
- #' @name rtables_access+ #' covariates = "REGION1", |
||
| 12 | +101 |
- NULL+ #' strata = c("STRATA1", "STRATA2")
|
||
| 13 | +102 |
-
+ #' ), |
||
| 14 | +103 |
- #' @describeIn rtables_access Helper function to extract the first values from each content+ #' data = adtte_f[NULL, ] |
||
| 15 | +104 |
- #' cell and from specified columns in a `TableRow`. Defaults to all columns.+ #' ) |
||
| 16 | +105 |
#' |
||
| 17 | +106 |
- #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table.+ #' @export |
||
| 18 | +107 |
- #' @param col_names (`character`)\cr the names of the columns to extract from.+ h_coxreg_mult_cont_df <- function(variables, |
||
| 19 | +108 |
- #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided,+ data, |
||
| 20 | +109 |
- #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single+ control = control_coxreg()) {
|
||
| 21 | -+ | |||
| 110 | +27x |
- #' column split.+ if ("strat" %in% names(variables)) {
|
||
| 22 | -+ | |||
| 111 | +! |
- #'+ warning( |
||
| 23 | -+ | |||
| 112 | +! |
- #' @return+ "Warning: the `strat` element name of the `variables` list argument to `h_coxreg_mult_cont_df() ", |
||
| 24 | -+ | |||
| 113 | +! |
- #' * `h_row_first_values()` returns a `vector` of numeric values.+ "was deprecated in tern 0.9.3.\n ", |
||
| 25 | -+ | |||
| 114 | +! |
- #'+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 26 | +115 |
- #' @examples+ ) |
||
| 27 | -+ | |||
| 116 | +! |
- #' tbl <- basic_table() %>%+ variables[["strata"]] <- variables[["strat"]] |
||
| 28 | +117 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 29 | +118 |
- #' split_rows_by("RACE") %>%
+
|
||
| 30 | -+ | |||
| 119 | +27x |
- #' analyze("AGE", function(x) {
+ assert_df_with_variables(data, variables) |
||
| 31 | -+ | |||
| 120 | +27x |
- #' list(+ checkmate::assert_list(control, names = "named") |
||
| 32 | -+ | |||
| 121 | +27x |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"),+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
||
| 33 | -+ | |||
| 122 | +27x |
- #' "n" = length(x),+ conf_level <- control[["conf_level"]] |
||
| 34 | -+ | |||
| 123 | +27x |
- #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)")+ pval_label <- paste0( |
||
| 35 | +124 |
- #' )+ # the regex capitalizes the first letter of the string / senetence. |
||
| 36 | -+ | |||
| 125 | +27x |
- #' }) %>%+ "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
|
||
| 37 | +126 |
- #' build_table(tern_ex_adsl) %>%+ ) |
||
| 38 | +127 |
- #' prune_table()+ # If there is any data, run model, otherwise return empty results. |
||
| 39 | -+ | |||
| 128 | +27x |
- #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]]+ if (nrow(data) > 0) {
|
||
| 40 | -+ | |||
| 129 | +26x |
- #' result <- max(h_row_first_values(tree_row_elem))+ bm_cols <- match(variables$biomarkers, names(data)) |
||
| 41 | -+ | |||
| 130 | +26x |
- #' result+ l_result <- lapply(variables$biomarkers, function(bm) {
|
||
| 42 | -+ | |||
| 131 | +52x |
- #'+ coxreg_list <- fit_coxreg_multivar( |
||
| 43 | -+ | |||
| 132 | +52x |
- #' @export+ variables = h_surv_to_coxreg_variables(variables, bm), |
||
| 44 | -+ | |||
| 133 | +52x |
- h_row_first_values <- function(table_row,+ data = data, |
||
| 45 | -+ | |||
| 134 | +52x |
- col_names = NULL,+ control = control |
||
| 46 | +135 |
- col_indices = NULL) {
+ ) |
||
| 47 | -727x | +136 | +52x |
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ result <- do.call( |
| 48 | -727x | +137 | +52x |
- checkmate::assert_integerish(col_indices)+ h_coxreg_multivar_extract, |
| 49 | -727x | +138 | +52x |
- checkmate::assert_subset(col_indices, seq_len(ncol(table_row)))+ c(list(var = bm), coxreg_list[c("mod", "data", "control")])
|
| 50 | +139 |
-
+ ) |
||
| 51 | -+ | |||
| 140 | +52x |
- # Main values are extracted+ data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y)) |
||
| 52 | -727x | +141 | +52x |
- row_vals <- row_values(table_row)[col_indices]+ data_fit$status <- as.logical(data_fit$status) |
| 53 | -+ | |||
| 142 | +52x |
-
+ median <- s_surv_time( |
||
| 54 | -+ | |||
| 143 | +52x |
- # Main return+ df = data_fit, |
||
| 55 | -727x | +144 | +52x |
- vapply(row_vals, function(rv) {
+ .var = "time", |
| 56 | -2066x | +145 | +52x |
- if (is.null(rv)) {
+ is_event = "status" |
| 57 | -727x | +146 | +52x |
- NA_real_+ )$median+ |
+
| 147 | +52x | +
+ data.frame( |
||
| 58 | +148 |
- } else {
+ # Dummy column needed downstream to create a nested header. |
||
| 59 | -2063x | +149 | +52x |
- rv[1L]+ biomarker = bm, |
| 60 | -+ | |||
| 150 | +52x |
- }+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE), |
||
| 61 | -727x | +151 | +52x |
- }, FUN.VALUE = numeric(1))+ n_tot = coxreg_list$mod$n, |
| 62 | -+ | |||
| 152 | +52x |
- }+ n_tot_events = coxreg_list$mod$nevent, |
||
| 63 | -+ | |||
| 153 | +52x |
-
+ median = as.numeric(median), |
||
| 64 | -+ | |||
| 154 | +52x |
- #' @describeIn rtables_access Helper function that extracts row values and checks if they are+ result[1L, c("hr", "lcl", "ucl")],
|
||
| 65 | -+ | |||
| 155 | +52x |
- #' convertible to integers (`integerish` values).+ conf_level = conf_level, |
||
| 66 | -+ | |||
| 156 | +52x |
- #'+ pval = result[1L, "pval"], |
||
| 67 | -+ | |||
| 157 | +52x |
- #' @return+ pval_label = pval_label, |
||
| 68 | -+ | |||
| 158 | +52x |
- #' * `h_row_counts()` returns a `vector` of numeric values.+ stringsAsFactors = FALSE |
||
| 69 | +159 |
- #'+ ) |
||
| 70 | +160 |
- #' @examples+ }) |
||
| 71 | -+ | |||
| 161 | +26x |
- #' # Row counts (integer values)+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 72 | +162 |
- #' # h_row_counts(tree_row_elem) # Fails because there are no integers+ } else {
|
||
| 73 | -+ | |||
| 163 | +1x |
- #' # Using values with integers+ data.frame( |
||
| 74 | -+ | |||
| 164 | +1x |
- #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]]+ biomarker = variables$biomarkers, |
||
| 75 | -+ | |||
| 165 | +1x |
- #' result <- h_row_counts(tree_row_elem)+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE), |
||
| 76 | -+ | |||
| 166 | +1x |
- #' # result+ n_tot = 0L, |
||
| 77 | -+ | |||
| 167 | +1x |
- #'+ n_tot_events = 0L, |
||
| 78 | -+ | |||
| 168 | +1x |
- #' @export+ median = NA, |
||
| 79 | -+ | |||
| 169 | +1x |
- h_row_counts <- function(table_row,+ hr = NA, |
||
| 80 | -+ | |||
| 170 | +1x |
- col_names = NULL,+ lcl = NA, |
||
| 81 | -+ | |||
| 171 | +1x |
- col_indices = NULL) {
+ ucl = NA, |
||
| 82 | -727x | +172 | +1x |
- counts <- h_row_first_values(table_row, col_names, col_indices)+ conf_level = conf_level, |
| 83 | -727x | +173 | +1x |
- checkmate::assert_integerish(counts)+ pval = NA, |
| 84 | -727x | +174 | +1x |
- counts+ pval_label = pval_label, |
| 85 | -+ | |||
| 175 | +1x |
- }+ row.names = seq_along(variables$biomarkers),+ |
+ ||
| 176 | +1x | +
+ stringsAsFactors = FALSE |
||
| 86 | +177 |
-
+ ) |
||
| 87 | +178 |
- #' @describeIn rtables_access helper function to extract fractions from specified columns in a `TableRow`.+ } |
||
| 88 | +179 |
- #' More specifically it extracts the second values from each content cell and checks it is a fraction.+ } |
||
| 89 | +180 |
- #'+ |
||
| 90 | +181 |
- #' @return+ #' @describeIn h_survival_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing |
||
| 91 | +182 |
- #' * `h_row_fractions()` returns a `vector` of proportions.+ #' the results for a single biomarker. |
||
| 92 | +183 |
#' |
||
| 93 | +184 |
- #' @examples+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 94 | +185 |
- #' # Row fractions+ #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are |
||
| 95 | +186 |
- #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]]+ #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()], |
||
| 96 | +187 |
- #' h_row_fractions(tree_row_elem)+ #' see the example). |
||
| 97 | +188 |
#' |
||
| 98 | +189 |
- #' @export+ #' @return |
||
| 99 | +190 |
- h_row_fractions <- function(table_row,+ #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
||
| 100 | +191 |
- col_names = NULL,+ #' |
||
| 101 | +192 |
- col_indices = NULL) {
+ #' @examples |
||
| 102 | -243x | +|||
| 193 | +
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
|||
| 103 | -243x | +|||
| 194 | +
- row_vals <- row_values(table_row)[col_indices]+ #' df1 <- df[1, ] |
|||
| 104 | -243x | +|||
| 195 | +
- fractions <- sapply(row_vals, "[", 2L)+ #' df1$subgroup <- "All patients" |
|||
| 105 | -243x | +|||
| 196 | +
- checkmate::assert_numeric(fractions, lower = 0, upper = 1)+ #' df1$row_type <- "content" |
|||
| 106 | -243x | +|||
| 197 | +
- fractions+ #' df1$var <- "ALL" |
|||
| 107 | +198 |
- }+ #' df1$var_label <- "All patients" |
||
| 108 | +199 |
-
+ #' h_tab_surv_one_biomarker( |
||
| 109 | +200 |
- #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table.+ #' df1, |
||
| 110 | +201 |
- #'+ #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 111 | +202 |
- #' @param table (`VTableNodeInfo`)\cr an occurrence table or row.+ #' time_unit = "days" |
||
| 112 | +203 |
- #'+ #' ) |
||
| 113 | +204 |
- #' @return+ #' |
||
| 114 | +205 |
- #' * `h_col_counts()` returns a `vector` of column counts.+ #' @export |
||
| 115 | +206 |
- #'+ h_tab_surv_one_biomarker <- function(df, |
||
| 116 | +207 |
- #' @export+ vars, |
||
| 117 | +208 |
- h_col_counts <- function(table,+ time_unit, |
||
| 118 | +209 |
- col_names = NULL,+ na_str = default_na_str(), |
||
| 119 | +210 |
- col_indices = NULL) {
+ .indent_mods = 0L, |
||
| 120 | -304x | +|||
| 211 | +
- col_indices <- check_names_indices(table, col_names, col_indices)+ ...) {
|
|||
| 121 | -304x | +212 | +8x |
- counts <- col_counts(table)[col_indices]+ afuns <- a_survival_subgroups(na_str = na_str)[vars] |
| 122 | -304x | +213 | +8x |
- stats::setNames(counts, col_names)+ colvars <- d_survival_subgroups_colvars( |
| 123 | -+ | |||
| 214 | +8x |
- }+ vars, |
||
| 124 | -+ | |||
| 215 | +8x |
-
+ conf_level = df$conf_level[1], |
||
| 125 | -+ | |||
| 216 | +8x |
- #' @describeIn rtables_access Helper function to get first row of content table of current table.+ method = df$pval_label[1], |
||
| 126 | -+ | |||
| 217 | +8x |
- #'+ time_unit = time_unit |
||
| 127 | +218 |
- #' @return+ ) |
||
| 128 | -+ | |||
| 219 | +8x |
- #' * `h_content_first_row()` returns a row from an `rtables` table.+ h_tab_one_biomarker( |
||
| 129 | -+ | |||
| 220 | +8x |
- #'+ df = df, |
||
| 130 | -+ | |||
| 221 | +8x |
- #' @export+ afuns = afuns, |
||
| 131 | -+ | |||
| 222 | +8x |
- h_content_first_row <- function(table) {
+ colvars = colvars, |
||
| 132 | -27x | +223 | +8x |
- ct <- content_table(table)+ na_str = na_str, |
| 133 | -27x | +224 | +8x |
- tree_children(ct)[[1]]+ .indent_mods = .indent_mods, |
| 134 | +225 |
- }+ ... |
||
| 135 | +226 |
-
+ ) |
||
| 136 | +227 |
- #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree.+ } |
| 137 | +1 |
- #'+ #' Sort Data by `PK PARAM` Variable |
||
| 138 | +2 |
- #' @return+ #' |
||
| 139 | +3 |
- #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf.+ #' @description `r lifecycle::badge("stable")`
|
||
| 140 | +4 |
#' |
||
| 141 | +5 |
- #' @keywords internal+ #' @param pk_data (`data.frame`)\cr `Pharmacokinetics` dataframe |
||
| 142 | +6 |
- is_leaf_table <- function(table) {
+ #' @param key_var (`character`)\cr key variable used to merge pk_data and metadata created by `d_pkparam()` |
||
| 143 | -168x | +|||
| 7 | +
- children <- tree_children(table)+ #' |
|||
| 144 | -168x | +|||
| 8 | +
- child_classes <- unique(sapply(children, class))+ #' @return A PK `data.frame` sorted by a `PARAM` variable. |
|||
| 145 | -168x | +|||
| 9 | +
- identical(child_classes, "ElementaryTable")+ #' |
|||
| 146 | +10 |
- }+ #' @examples |
||
| 147 | +11 |
-
+ #' library(dplyr) |
||
| 148 | +12 |
- #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices.+ #' |
||
| 149 | +13 |
- #'+ #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
|
||
| 150 | +14 |
- #' @return+ #' pk_ordered_data <- h_pkparam_sort(adpp) |
||
| 151 | +15 |
- #' * `check_names_indices` returns column indices.+ #' |
||
| 152 | +16 |
- #'+ #' @export |
||
| 153 | +17 |
- #' @keywords internal+ h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
+ |
+ ||
| 18 | +4x | +
+ assert_df_with_variables(pk_data, list(key_var = key_var))+ |
+ ||
| 19 | +4x | +
+ pk_data$PARAMCD <- pk_data[[key_var]] |
||
| 154 | +20 |
- check_names_indices <- function(table_row,+ + |
+ ||
| 21 | +4x | +
+ ordered_pk_data <- d_pkparam() |
||
| 155 | +22 |
- col_names = NULL,+ |
||
| 156 | +23 |
- col_indices = NULL) {
+ # Add the numeric values from ordered_pk_data to pk_data |
||
| 157 | -1274x | +24 | +4x |
- if (!is.null(col_names)) {
+ joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffix = c("", ".y"))
|
| 158 | -1231x | +|||
| 25 | +
- if (!is.null(col_indices)) {
+
|
|||
| 159 | -! | +|||
| 26 | +4x |
- stop(+ joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
|
||
| 160 | -! | +|||
| 27 | +
- "Inserted both col_names and col_indices when selecting row values. ",+ |
|||
| 161 | -! | +|||
| 28 | +4x |
- "Please choose one."+ joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER) |
||
| 162 | +29 |
- )+ |
||
| 163 | +30 |
- }+ # Then order PARAM based on this column |
||
| 164 | -1231x | +31 | +4x |
- col_indices <- h_col_indices(table_row, col_names)+ joined_data$PARAM <- factor(joined_data$PARAM,+ |
+
| 32 | +4x | +
+ levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ |
+ ||
| 33 | +4x | +
+ ordered = TRUE |
||
| 165 | +34 |
- }+ )+ |
+ ||
| 35 | ++ | + | ||
| 166 | -1274x | +36 | +4x |
- if (is.null(col_indices)) {
+ joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY, |
| 167 | -37x | +37 | +4x |
- ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row))+ levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]), |
| 168 | -37x | +38 | +4x |
- col_indices <- seq_len(ll)+ ordered = TRUE |
| 169 | +39 |
- }+ ) |
||
| 170 | +40 | |||
| 171 | -1274x | +41 | +4x |
- return(col_indices)+ joined_data |
| 172 | +42 |
}@@ -150172,14 +152696,14 @@ tern coverage - 90.46% |
| 1 |
- #' Counting Patients Summing Exposure Across All Patients in Columns+ #' Formatting Functions |
|||
| 5 |
- #' Counting the number of patients and summing analysis value (i.e exposure values) across all patients+ #' See below for the list of formatting functions created in `tern` to work with `rtables`. |
|||
| 6 |
- #' when a column table layout is required.+ #' |
|||
| 7 |
- #'+ #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional |
|||
| 8 |
- #' @inheritParams argument_convention+ #' custom formats can be created via the [`formatters::sprintf_format()`] function. |
|||
| 9 |
- #' @param ex_var (`character`)\cr name of the variable within `df` containing exposure values.+ #' |
|||
| 10 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will be used as label.+ #' @family formatting functions |
|||
| 11 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run+ #' @name formatting_functions |
|||
| 12 |
- #' `get_stats("analyze_patients_exposure_in_cols")` to see available statistics for this function.
+ NULL |
|||
| 13 |
- #'+ |
|||
| 14 |
- #' @name summarize_patients_exposure_in_cols+ #' Formatting Fraction and Percentage |
|||
| 15 |
- #' @order 1+ #' |
|||
| 16 |
- NULL+ #' @description `r lifecycle::badge("stable")`
|
|||
| 17 |
-
+ #' |
|||
| 18 |
- #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers+ #' Formats a fraction together with ratio in percent. |
|||
| 19 |
- #' of patients and the sum of exposure across all patients.+ #' |
|||
| 20 |
- #'+ #' @param x (`integer`)\cr with elements `num` and `denom`. |
|||
| 21 |
- #' @return+ #' @param ... required for `rtables` interface. |
|||
| 22 |
- #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics:+ #' |
|||
| 23 |
- #' * `n_patients`: Number of unique patients in `df`.+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
|||
| 24 |
- #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`.+ #' |
|||
| 25 |
- #'+ #' @examples |
|||
| 26 |
- #' @keywords internal+ #' format_fraction(x = c(num = 2L, denom = 3L)) |
|||
| 27 |
- s_count_patients_sum_exposure <- function(df,+ #' format_fraction(x = c(num = 0L, denom = 3L)) |
|||
| 28 |
- ex_var = "AVAL",+ #' |
|||
| 29 |
- id = "USUBJID",+ #' @family formatting functions |
|||
| 30 |
- labelstr = "",+ #' @export |
|||
| 31 |
- .stats = c("n_patients", "sum_exposure"),
+ format_fraction <- function(x, ...) {
|
|||
| 32 | -+ | 4x |
- .N_col, # nolint+ attr(x, "label") <- NULL |
|
| 33 |
- custom_label = NULL) {
+
|
|||
| 34 | -56x | +4x |
- assert_df_with_variables(df, list(ex_var = ex_var, id = id))+ checkmate::assert_vector(x) |
|
| 35 | -56x | +4x |
- checkmate::assert_string(id)+ checkmate::assert_count(x["num"]) |
|
| 36 | -56x | +2x |
- checkmate::assert_string(labelstr)+ checkmate::assert_count(x["denom"]) |
|
| 37 | -56x | +
- checkmate::assert_string(custom_label, null.ok = TRUE)+ |
||
| 38 | -56x | +2x |
- checkmate::assert_numeric(df[[ex_var]])+ result <- if (x["num"] == 0) {
|
|
| 39 | -56x | +1x |
- checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
+ paste0(x["num"], "/", x["denom"]) |
|
| 40 |
-
+ } else {
|
|||
| 41 | -56x | +1x |
- row_label <- if (labelstr != "") {
+ paste0( |
|
| 42 | -! | +1x |
- labelstr+ x["num"], "/", x["denom"], |
|
| 43 | -56x | +1x |
- } else if (!is.null(custom_label)) {
+ " (", round(x["num"] / x["denom"] * 100, 1), "%)"
|
|
| 44 | -48x | +
- custom_label+ ) |
||
| 45 |
- } else {
+ } |
|||
| 46 | -8x | +
- "Total patients numbers/person time"+ |
||
| 47 | -+ | 2x |
- }+ return(result) |
|
| 48 |
-
+ } |
|||
| 49 | -56x | +
- y <- list()+ |
||
| 50 |
-
+ #' Formatting Fraction and Percentage with Fixed Single Decimal Place |
|||
| 51 | -56x | +
- if ("n_patients" %in% .stats) {
+ #' |
||
| 52 | -23x | +
- y$n_patients <-+ #' @description `r lifecycle::badge("stable")`
|
||
| 53 | -23x | +
- formatters::with_label(+ #' |
||
| 54 | -23x | +
- s_num_patients_content(+ #' Formats a fraction together with ratio in percent with fixed single decimal place. |
||
| 55 | -23x | +
- df = df,+ #' Includes trailing zero in case of whole number percentages to always keep one decimal place. |
||
| 56 | -23x | +
- .N_col = .N_col, # nolint+ #' |
||
| 57 | -23x | +
- .var = id,+ #' @param x (`integer`)\cr with elements `num` and `denom`. |
||
| 58 | -23x | +
- labelstr = ""+ #' @param ... required for `rtables` interface. |
||
| 59 | -23x | +
- )$unique,+ #' |
||
| 60 | -23x | +
- row_label+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
||
| 61 |
- )+ #' |
|||
| 62 |
- }+ #' @examples |
|||
| 63 | -56x | +
- if ("sum_exposure" %in% .stats) {
+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L)) |
||
| 64 | -34x | +
- y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label)+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L)) |
||
| 65 |
- }+ #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L)) |
|||
| 66 | -56x | +
- y+ #' |
||
| 67 |
- }+ #' @family formatting functions |
|||
| 68 |
-
+ #' @export |
|||
| 69 |
- #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in+ format_fraction_fixed_dp <- function(x, ...) {
|
|||
| 70 | -+ | 3x |
- #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in+ attr(x, "label") <- NULL |
|
| 71 | -+ | 3x |
- #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`.+ checkmate::assert_vector(x) |
|
| 72 | -+ | 3x |
- #'+ checkmate::assert_count(x["num"]) |
|
| 73 | -+ | 3x |
- #' @return+ checkmate::assert_count(x["denom"]) |
|
| 74 |
- #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()].+ |
|||
| 75 | -+ | 3x |
- #'+ result <- if (x["num"] == 0) {
|
|
| 76 | -+ | 1x |
- #' @examples+ paste0(x["num"], "/", x["denom"]) |
|
| 77 |
- #' a_count_patients_sum_exposure(+ } else {
|
|||
| 78 | -+ | 2x |
- #' df = df,+ paste0( |
|
| 79 | -+ | 2x |
- #' var = "SEX",+ x["num"], "/", x["denom"], |
|
| 80 | -+ | 2x |
- #' .N_col = nrow(df),+ " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
|
|
| 81 |
- #' .stats = "n_patients"+ ) |
|||
| 82 |
- #' )+ } |
|||
| 83 | -+ | 3x |
- #'+ return(result) |
|
| 84 |
- #' @export+ } |
|||
| 85 |
- a_count_patients_sum_exposure <- function(df,+ |
|||
| 86 |
- var = NULL,+ #' Formatting Count and Fraction |
|||
| 87 |
- ex_var = "AVAL",+ #' |
|||
| 88 |
- id = "USUBJID",+ #' @description `r lifecycle::badge("stable")`
|
|||
| 89 |
- add_total_level = FALSE,+ #' |
|||
| 90 |
- custom_label = NULL,+ #' Formats a count together with fraction with special consideration when count is `0`. |
|||
| 91 |
- labelstr = "",+ #' |
|||
| 92 |
- .N_col, # nolint+ #' @param x (`integer`)\cr vector of length 2, count and fraction. |
|||
| 93 |
- .stats,+ #' @param ... required for `rtables` interface. |
|||
| 94 |
- .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
+ #' |
|||
| 95 | -32x | +
- checkmate::assert_flag(add_total_level)+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
||
| 96 |
-
+ #' |
|||
| 97 | -32x | +
- if (!is.null(var)) {
+ #' @examples |
||
| 98 | -21x | +
- assert_df_with_variables(df, list(var = var))+ #' format_count_fraction(x = c(2, 0.6667)) |
||
| 99 | -21x | +
- df[[var]] <- as.factor(df[[var]])+ #' format_count_fraction(x = c(0, 0)) |
||
| 100 |
- }+ #' |
|||
| 101 |
-
+ #' @family formatting functions |
|||
| 102 | -32x | +
- y <- list()+ #' @export |
||
| 103 | -32x | +
- if (is.null(var)) {
+ format_count_fraction <- function(x, ...) {
|
||
| 104 | -11x | +3x |
- y[[.stats]] <- list(Total = s_count_patients_sum_exposure(+ attr(x, "label") <- NULL |
|
| 105 | -11x | +
- df = df,+ |
||
| 106 | -11x | +3x |
- ex_var = ex_var,+ if (any(is.na(x))) {
|
|
| 107 | -11x | +1x |
- id = id,+ return("NA")
|
|
| 108 | -11x | +
- labelstr = labelstr,+ } |
||
| 109 | -11x | +
- .N_col = .N_col,+ |
||
| 110 | -11x | +2x |
- .stats = .stats,+ checkmate::assert_vector(x) |
|
| 111 | -11x | +2x |
- custom_label = custom_label+ checkmate::assert_integerish(x[1]) |
|
| 112 | -11x | +2x |
- )[[.stats]])+ assert_proportion_value(x[2], include_boundaries = TRUE) |
|
| 113 |
- } else {
+
|
|||
| 114 | -21x | +2x |
- for (lvl in levels(df[[var]])) {
+ result <- if (x[1] == 0) {
|
|
| 115 | -42x | +1x |
- y[[.stats]][[lvl]] <- s_count_patients_sum_exposure(+ "0" |
|
| 116 | -42x | +
- df = subset(df, get(var) == lvl),+ } else {
|
||
| 117 | -42x | +1x |
- ex_var = ex_var,+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
|
| 118 | -42x | +
- id = id,+ } |
||
| 119 | -42x | +
- labelstr = labelstr,+ |
||
| 120 | -42x | +2x |
- .N_col = .N_col,+ return(result) |
|
| 121 | -42x | +
- .stats = .stats,+ } |
||
| 122 | -42x | +
- custom_label = lvl+ |
||
| 123 | -42x | +
- )[[.stats]]+ #' Formatting Count and Percentage with Fixed Single Decimal Place |
||
| 124 |
- }+ #' |
|||
| 125 | -21x | +
- if (add_total_level) {
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 126 | -2x | +
- y[[.stats]][["Total"]] <- s_count_patients_sum_exposure(+ #' |
||
| 127 | -2x | +
- df = df,+ #' Formats a count together with fraction with special consideration when count is `0`. |
||
| 128 | -2x | +
- ex_var = ex_var,+ #' |
||
| 129 | -2x | +
- id = id,+ #' @param x (`integer`)\cr vector of length 2, count and fraction. |
||
| 130 | -2x | +
- labelstr = labelstr,+ #' @param ... required for `rtables` interface. |
||
| 131 | -2x | +
- .N_col = .N_col,+ #' |
||
| 132 | -2x | +
- .stats = .stats,+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
||
| 133 | -2x | +
- custom_label = custom_label+ #' |
||
| 134 | -2x | +
- )[[.stats]]+ #' @examples |
||
| 135 |
- }+ #' format_count_fraction_fixed_dp(x = c(2, 0.6667)) |
|||
| 136 |
- }+ #' format_count_fraction_fixed_dp(x = c(2, 0.5)) |
|||
| 137 |
-
+ #' format_count_fraction_fixed_dp(x = c(0, 0)) |
|||
| 138 | -32x | +
- in_rows(.list = y[[.stats]], .formats = .formats[[.stats]])+ #' |
||
| 139 |
- }+ #' @family formatting functions |
|||
| 140 |
-
+ #' @export |
|||
| 141 |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ format_count_fraction_fixed_dp <- function(x, ...) {
|
|||
| 142 | -+ | 3x |
- #' function arguments and additional format arguments. This function is a wrapper for+ attr(x, "label") <- NULL |
|
| 143 |
- #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()].+ |
|||
| 144 | -+ | 3x |
- #'+ if (any(is.na(x))) {
|
|
| 145 | -+ | ! |
- #' @return+ return("NA")
|
|
| 146 |
- #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ } |
|||
| 147 |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ |
|||
| 148 | -+ | 3x |
- #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ checkmate::assert_vector(x) |
|
| 149 | -+ | 3x |
- #' columns, to the table layout.+ checkmate::assert_integerish(x[1]) |
|
| 150 | -+ | 3x |
- #'+ assert_proportion_value(x[2], include_boundaries = TRUE) |
|
| 151 |
- #' @examples+ |
|||
| 152 | -+ | 3x |
- #' lyt5 <- basic_table() %>%+ result <- if (x[1] == 0) {
|
|
| 153 | -+ | 1x |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)+ "0" |
|
| 154 | -+ | 3x |
- #'+ } else if (x[2] == 1) {
|
|
| 155 | -+ | ! |
- #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl)+ sprintf("%d (100%%)", x[1])
|
|
| 156 |
- #' result5+ } else {
|
|||
| 157 | -+ | 2x |
- #'+ sprintf("%d (%.1f%%)", x[1], x[2] * 100)
|
|
| 158 |
- #' lyt6 <- basic_table() %>%+ } |
|||
| 159 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")+ |
|||
| 160 | -+ | 3x |
- #'+ return(result) |
|
| 161 |
- #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl)+ } |
|||
| 162 |
- #' result6+ |
|||
| 163 |
- #'+ #' Formatting Count and Fraction with Special Case for Count < 10 |
|||
| 164 |
- #' @export+ #' |
|||
| 165 |
- #' @order 3+ #' @description `r lifecycle::badge("stable")`
|
|||
| 166 |
- summarize_patients_exposure_in_cols <- function(lyt, # nolint+ #' |
|||
| 167 |
- var,+ #' Formats a count together with fraction with special consideration when count is less than 10. |
|||
| 168 |
- ex_var = "AVAL",+ #' |
|||
| 169 |
- id = "USUBJID",+ #' @inheritParams format_count_fraction |
|||
| 170 |
- add_total_level = FALSE,+ #' |
|||
| 171 |
- custom_label = NULL,+ #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed. |
|||
| 172 |
- col_split = TRUE,+ #' |
|||
| 173 |
- na_str = default_na_str(),+ #' @examples |
|||
| 174 |
- ...,+ #' format_count_fraction_lt10(x = c(275, 0.9673)) |
|||
| 175 |
- .stats = c("n_patients", "sum_exposure"),
+ #' format_count_fraction_lt10(x = c(2, 0.6667)) |
|||
| 176 |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ #' format_count_fraction_lt10(x = c(9, 1)) |
|||
| 177 |
- .indent_mods = NULL) {
+ #' |
|||
| 178 | -3x | +
- extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...)+ #' @family formatting functions |
||
| 179 |
-
+ #' @export |
|||
| 180 | -3x | +
- if (col_split) {
+ format_count_fraction_lt10 <- function(x, ...) {
|
||
| 181 | -3x | +7x |
- lyt <- split_cols_by_multivar(+ attr(x, "label") <- NULL |
|
| 182 | -3x | +
- lyt = lyt,+ |
||
| 183 | -3x | +7x |
- vars = rep(var, length(.stats)),+ if (any(is.na(x))) {
|
|
| 184 | -3x | +1x |
- varlabels = .labels[.stats],+ return("NA")
|
|
| 185 | -3x | +
- extra_args = list(.stats = .stats)+ } |
||
| 186 |
- )+ |
|||
| 187 | -+ | 6x |
- }+ checkmate::assert_vector(x) |
|
| 188 | -3x | +6x |
- summarize_row_groups(+ checkmate::assert_integerish(x[1]) |
|
| 189 | -3x | +6x |
- lyt = lyt,+ assert_proportion_value(x[2], include_boundaries = TRUE) |
|
| 190 | -3x | +
- var = var,+ |
||
| 191 | -3x | +6x |
- cfun = a_count_patients_sum_exposure,+ result <- if (x[1] < 10) {
|
|
| 192 | 3x |
- na_str = na_str,+ paste0(x[1]) |
||
| 193 | -3x | +
- extra_args = extra_args+ } else {
|
||
| 194 | -+ | 3x |
- )+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
|
| 195 |
- }+ } |
|||
| 197 | -+ | 6x |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ return(result) |
|
| 198 |
- #' function arguments and additional format arguments. This function is a wrapper for+ } |
|||
| 199 |
- #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].+ |
|||
| 200 |
- #'+ #' Formatting: XX as Formatting Function |
|||
| 201 |
- #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required+ #' |
|||
| 202 |
- #' column split has been done already earlier in the layout pipe.+ #' Translate a string where x and dots are interpreted as number place |
|||
| 203 |
- #'+ #' holders, and others as formatting elements. |
|||
| 204 |
- #' @return+ #' |
|||
| 205 |
- #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ #' @param str (`string`)\cr template. |
|||
| 206 |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ #' |
|||
| 207 |
- #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ #' @return An `rtables` formatting function. |
|||
| 208 |
- #' columns, to the table layout.+ #' |
|||
| 209 |
- #'+ #' @examples |
|||
| 210 |
- #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows,+ #' test <- list(c(1.658, 0.5761), c(1e1, 785.6)) |
|||
| 211 |
- #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple+ #' |
|||
| 212 |
- #' pages when pagination is used.+ #' z <- format_xx("xx (xx.x)")
|
|||
| 213 |
- #'+ #' sapply(test, z) |
|||
| 214 |
- #' @examples+ #' |
|||
| 215 |
- #' set.seed(1)+ #' z <- format_xx("xx.x - xx.x")
|
|||
| 216 |
- #' df <- data.frame(+ #' sapply(test, z) |
|||
| 217 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ #' |
|||
| 218 |
- #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
+ #' z <- format_xx("xx.x, incl. xx.x% NE")
|
|||
| 219 |
- #' SEX = c(rep("Female", 6), rep("Male", 6)),
+ #' sapply(test, z) |
|||
| 220 |
- #' AVAL = as.numeric(sample(seq(1, 20), 12)),+ #' |
|||
| 221 |
- #' stringsAsFactors = TRUE+ #' @family formatting functions |
|||
| 222 |
- #' )+ #' @export |
|||
| 223 |
- #' adsl <- data.frame(+ format_xx <- function(str) {
|
|||
| 224 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ # Find position in the string. |
|||
| 225 | -+ | 1x |
- #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
+ positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE) |
|
| 226 | -+ | 1x |
- #' SEX = c(rep("Female", 2), rep("Male", 2)),
+ x_positions <- regmatches(x = str, m = positions)[[1]] |
|
| 227 |
- #' stringsAsFactors = TRUE+ |
|||
| 228 |
- #' )+ # Roundings depends on the number of x behind [.]. |
|||
| 229 | -+ | 1x |
- #'+ roundings <- lapply( |
|
| 230 | -+ | 1x |
- #' lyt <- basic_table() %>%+ X = x_positions, |
|
| 231 | -+ | 1x |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ function(x) {
|
|
| 232 | -+ | 2x |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%+ y <- strsplit(split = "\\.", x = x)[[1]] |
|
| 233 | -+ | 2x |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE)+ rounding <- function(x) {
|
|
| 234 | -+ | 4x |
- #' result <- build_table(lyt, df = df, alt_counts_df = adsl)+ round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0)) |
|
| 235 |
- #' result+ } |
|||
| 236 | -+ | 2x |
- #'+ return(rounding) |
|
| 237 |
- #' lyt2 <- basic_table() %>%+ } |
|||
| 238 |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ ) |
|||
| 239 |
- #' summarize_patients_exposure_in_cols(+ |
|||
| 240 | -+ | 1x |
- #' var = "AVAL", col_split = TRUE,+ rtable_format <- function(x, output) {
|
|
| 241 | -+ | 2x |
- #' .stats = "n_patients", custom_label = "some custom label"+ values <- Map(y = x, fun = roundings, function(y, fun) fun(y)) |
|
| 242 | -+ | 2x |
- #' ) %>%+ regmatches(x = str, m = positions)[[1]] <- values |
|
| 243 | -+ | 2x |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL")+ return(str) |
|
| 244 |
- #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)+ } |
|||
| 245 |
- #' result2+ |
|||
| 246 | -+ | 1x |
- #'+ return(rtable_format) |
|
| 247 |
- #' lyt3 <- basic_table() %>%+ } |
|||
| 248 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL")+ |
|||
| 249 |
- #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)+ #' Formatting Numeric Values By Significant Figures |
|||
| 250 |
- #' result3+ #' |
|||
| 251 |
- #'+ #' Format numeric values to print with a specified number of significant figures. |
|||
| 252 |
- #' # Adding total levels and custom label+ #' |
|||
| 253 |
- #' lyt4 <- basic_table(+ #' @param sigfig (`integer`)\cr number of significant figures to display. |
|||
| 254 |
- #' show_colcounts = TRUE+ #' @param format (`character`)\cr the format label (string) to apply when printing the value. Decimal |
|||
| 255 |
- #' ) %>%+ #' places in string are ignored in favor of formatting by significant figures. Formats options are: |
|||
| 256 |
- #' analyze_patients_exposure_in_cols(+ #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`. |
|||
| 257 |
- #' var = "ARMCD",+ #' @param num_fmt (`character`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for |
|||
| 258 |
- #' col_split = TRUE,+ #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`) |
|||
| 259 |
- #' add_total_level = TRUE,+ #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the |
|||
| 260 |
- #' custom_label = "TOTAL"+ #' [formatC()] `format` argument for more options. |
|||
| 261 |
- #' ) %>%+ #' |
|||
| 262 |
- #' append_topleft(c("", "Sex"))
+ #' @return An `rtables` formatting function. |
|||
| 264 |
- #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)+ #' @examples |
|||
| 265 |
- #' result4+ #' fmt_3sf <- format_sigfig(3) |
|||
| 266 |
- #'+ #' fmt_3sf(1.658) |
|||
| 267 |
- #' @export+ #' fmt_3sf(1e1) |
|||
| 268 |
- #' @order 2+ #' |
|||
| 269 |
- analyze_patients_exposure_in_cols <- function(lyt, # nolint+ #' fmt_5sf <- format_sigfig(5) |
|||
| 270 |
- var = NULL,+ #' fmt_5sf(0.57) |
|||
| 271 |
- ex_var = "AVAL",+ #' fmt_5sf(0.000025645) |
|||
| 272 |
- id = "USUBJID",+ #' |
|||
| 273 |
- add_total_level = FALSE,+ #' @family formatting functions |
|||
| 274 |
- custom_label = NULL,+ #' @export |
|||
| 275 |
- col_split = TRUE,+ format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
|
|||
| 276 | -+ | 2x |
- na_str = default_na_str(),+ checkmate::assert_integerish(sigfig) |
|
| 277 | -+ | 2x |
- .stats = c("n_patients", "sum_exposure"),
+ format <- gsub("xx\\.|xx\\.x+", "xx", format)
|
|
| 278 | -+ | 2x |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
|
|
| 279 | -+ | 2x |
- .indent_mods = 0L,+ function(x, ...) {
|
|
| 280 | -+ | ! |
- ...) {
+ if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
|
|
| 281 | -6x | +9x |
- extra_args <- list(+ num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#") |
|
| 282 | -6x | +9x |
- var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...+ num <- gsub("\\.$", "", num) # remove trailing "."
|
|
| 283 | - |
- )- |
- ||
| 284 | -||||
| 285 | -6x | -
- if (col_split) {
- |
- ||
| 286 | -4x | -
- lyt <- split_cols_by_multivar(- |
- ||
| 287 | -4x | -
- lyt = lyt,- |
- ||
| 288 | -4x | -
- vars = rep(ex_var, length(.stats)),- |
- ||
| 289 | -4x | -
- varlabels = .labels[.stats],- |
- ||
| 290 | -4x | -
- extra_args = list(.stats = .stats)- |
- ||
| 291 | -+ | 284 | +9x |
- )+ format_value(num, format) |
| 292 | +285 |
} |
||
| 293 | -6x | -
- lyt <- lyt %>% analyze_colvars(- |
- ||
| 294 | -6x | -
- afun = a_count_patients_sum_exposure,- |
- ||
| 295 | -6x | -
- indent_mod = .indent_mods,- |
- ||
| 296 | -6x | -
- na_str = na_str,- |
- ||
| 297 | -6x | -
- extra_args = extra_args- |
- ||
| 298 | +286 |
- )- |
- ||
| 299 | -6x | -
- lyt+ } |
||
| 300 | +287 |
- }+ |
| 1 | +288 |
- #' Additional Assertions for `checkmate`+ #' Formatting Fraction with Lower Threshold |
||
| 2 | +289 |
#' |
||
| 3 | +290 |
- #' Additional assertion functions which can be used together with the `checkmate` package.+ #' @description `r lifecycle::badge("stable")`
|
||
| 4 | +291 |
#' |
||
| 5 | +292 |
- #' @inheritParams checkmate::assert_factor+ #' Formats a fraction when the second element of the input `x` is the fraction. It applies |
||
| 6 | +293 |
- #' @param x (`any`)\cr object to test.+ #' a lower threshold, below which it is just stated that the fraction is smaller than that. |
||
| 7 | +294 |
- #' @param df (`data.frame`)\cr data set to test.+ #' |
||
| 8 | +295 |
- #' @param variables (named `list` of `character`)\cr list of variables to test.+ #' @param threshold (`proportion`)\cr lower threshold. |
||
| 9 | +296 |
- #' @param include_boundaries (`logical`)\cr whether to include boundaries when testing+ #' |
||
| 10 | +297 |
- #' for proportions.+ #' @return An `rtables` formatting function that takes numeric input `x` where the second |
||
| 11 | +298 |
- #' @param na_level (`character`)\cr the string you have been using to represent NA or+ #' element is the fraction that is formatted. If the fraction is above or equal to the threshold, |
||
| 12 | +299 |
- #' missing data. For `NA` values please consider using directly [is.na()] or+ #' then it is displayed in percentage. If it is positive but below the threshold, it returns, |
||
| 13 | +300 |
- #' similar approaches.+ #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned. |
||
| 14 | +301 |
#' |
||
| 15 | +302 |
- #' @return Nothing if assertion passes, otherwise prints the error message.+ #' @examples |
||
| 16 | +303 |
- #'+ #' format_fun <- format_fraction_threshold(0.05) |
||
| 17 | +304 |
- #' @name assertions+ #' format_fun(x = c(20, 0.1)) |
||
| 18 | +305 |
- NULL+ #' format_fun(x = c(2, 0.01)) |
||
| 19 | +306 |
-
+ #' format_fun(x = c(0, 0)) |
||
| 20 | +307 |
- check_list_of_variables <- function(x) {
+ #' |
||
| 21 | +308 |
- # drop NULL elements in list+ #' @family formatting functions |
||
| 22 | -2369x | +|||
| 309 | +
- x <- Filter(Negate(is.null), x)+ #' @export |
|||
| 23 | +310 |
-
+ format_fraction_threshold <- function(threshold) {
|
||
| 24 | -2369x | +311 | +1x |
- res <- checkmate::check_list(x,+ assert_proportion_value(threshold) |
| 25 | -2369x | +312 | +1x |
- names = "named",+ string_below_threshold <- paste0("<", round(threshold * 100))
|
| 26 | -2369x | +313 | +1x |
- min.len = 1,+ function(x, ...) {
|
| 27 | -2369x | +314 | +3x |
- any.missing = FALSE,+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 28 | -2369x | +315 | +3x |
- types = "character"+ ifelse( |
| 29 | -+ | |||
| 316 | +3x |
- )+ x[2] > 0.01, |
||
| 30 | -+ | |||
| 317 | +3x |
- # no empty strings allowed+ round(x[2] * 100), |
||
| 31 | -2369x | +318 | +3x |
- if (isTRUE(res)) {
+ ifelse( |
| 32 | -2364x | +319 | +3x |
- res <- checkmate::check_character(unlist(x), min.chars = 1)+ x[2] == 0, |
| 33 | -+ | |||
| 320 | +3x |
- }+ "0", |
||
| 34 | -2369x | +321 | +3x |
- return(res)+ string_below_threshold |
| 35 | +322 |
- }+ ) |
||
| 36 | +323 |
- #' @describeIn assertions Checks whether `x` is a valid list of variable names.+ ) |
||
| 37 | +324 |
- #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`.+ } |
||
| 38 | +325 |
- #'+ } |
||
| 39 | +326 |
- #' @keywords internal+ |
||
| 40 | +327 |
- assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)+ #' Formatting Extreme Values |
||
| 41 | +328 |
-
+ #' |
||
| 42 | +329 |
- check_df_with_variables <- function(df, variables, na_level = NULL) {
- |
- ||
| 43 | -2110x | -
- checkmate::assert_data_frame(df)- |
- ||
| 44 | -2108x | -
- assert_list_of_variables(variables)+ #' @description `r lifecycle::badge("stable")`
|
||
| 45 | +330 |
-
+ #' |
||
| 46 | +331 |
- # flag for equal variables and column names- |
- ||
| 47 | -2106x | -
- err_flag <- all(unlist(variables) %in% colnames(df))- |
- ||
| 48 | -2106x | -
- checkmate::assert_flag(err_flag)+ #' `rtables` formatting functions that handle extreme values. |
||
| 49 | +332 | - - | -||
| 50 | -2106x | -
- if (isFALSE(err_flag)) {
- |
- ||
| 51 | -5x | -
- vars <- setdiff(unlist(variables), colnames(df))- |
- ||
| 52 | -5x | -
- return(paste(- |
- ||
| 53 | -5x | -
- deparse(substitute(df)),- |
- ||
| 54 | -5x | -
- "does not contain all specified variables as column names. Missing from dataframe:",- |
- ||
| 55 | -5x | -
- paste(vars, collapse = ", ")+ #' |
||
| 56 | +333 |
- ))+ #' @param digits (`integer`)\cr number of decimal places to display. |
||
| 57 | +334 |
- }+ #' |
||
| 58 | +335 |
- # checking if na_level is present and in which column- |
- ||
| 59 | -2101x | -
- if (!is.null(na_level)) {
- |
- ||
| 60 | -9x | -
- checkmate::assert_string(na_level)- |
- ||
| 61 | -9x | -
- res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))- |
- ||
| 62 | -9x | -
- if (any(res)) {
- |
- ||
| 63 | -1x | -
- return(paste0(- |
- ||
| 64 | -1x | -
- deparse(substitute(df)), " contains explicit na_level (", na_level,
- |
- ||
| 65 | -1x | -
- ") in the following columns: ", paste0(unlist(variables)[res],- |
- ||
| 66 | -1x | -
- collapse = ", "+ #' @details For each input, apply a format to the specified number of `digits`. If the value is |
||
| 67 | +336 |
- )+ #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is |
||
| 68 | +337 |
- ))+ #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2. |
||
| 69 | +338 |
- }+ #' If it is zero, then returns "0.00". |
||
| 70 | +339 |
- }- |
- ||
| 71 | -2100x | -
- return(TRUE)+ #' |
||
| 72 | +340 |
- }+ #' @family formatting functions |
||
| 73 | +341 |
- #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`.+ #' @name extreme_format |
||
| 74 | +342 |
- #' Please notice how this produces an error when not all variables are present in the+ NULL |
||
| 75 | +343 |
- #' data.frame while the opposite is not required.+ |
||
| 76 | +344 |
- #'+ #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings |
||
| 77 | +345 |
- #' @keywords internal+ #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`. |
||
| 78 | +346 |
- assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)+ #' |
||
| 79 | +347 |
-
+ #' @return |
||
| 80 | +348 |
- check_valid_factor <- function(x,+ #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds, |
||
| 81 | +349 |
- min.levels = 1, # nolint+ #' and `format_string`, with thresholds formatted as strings. |
||
| 82 | +350 |
- max.levels = NULL, # nolint+ #' |
||
| 83 | +351 |
- null.ok = TRUE, # nolint+ #' @examples |
||
| 84 | +352 |
- any.missing = TRUE, # nolint+ #' h_get_format_threshold(2L) |
||
| 85 | +353 |
- n.levels = NULL, # nolint+ #' |
||
| 86 | +354 |
- len = NULL) {
+ #' @export |
||
| 87 | +355 |
- # checks on levels insertion+ h_get_format_threshold <- function(digits = 2L) {
|
||
| 88 | -894x | +356 | +1498x |
- checkmate::assert_int(min.levels, lower = 1)+ checkmate::assert_integerish(digits) |
| 89 | +357 | |||
| 90 | -- |
- # main factor check- |
- ||
| 91 | -894x | -
- res <- checkmate::check_factor(x,- |
- ||
| 92 | -894x | +358 | +1498x |
- min.levels = min.levels,+ low_threshold <- 1 / (10 ^ digits) # styler: off |
| 93 | -894x | +359 | +1498x |
- null.ok = null.ok,+ high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off |
| 94 | -894x | +|||
| 360 | +
- max.levels = max.levels,+ |
|||
| 95 | -894x | +361 | +1498x |
- any.missing = any.missing,+ string_below_threshold <- paste0("<", low_threshold)
|
| 96 | -894x | +362 | +1498x |
- n.levels = n.levels+ string_above_threshold <- paste0(">", high_threshold)
|
| 97 | +363 |
- )+ |
||
| 98 | -+ | |||
| 364 | +1498x |
-
+ list( |
||
| 99 | -+ | |||
| 365 | +1498x |
- # no empty strings allowed+ "threshold" = c(low = low_threshold, high = high_threshold), |
||
| 100 | -894x | +366 | +1498x |
- if (isTRUE(res)) {
+ "format_string" = c(low = string_below_threshold, high = string_above_threshold) |
| 101 | -880x | +|||
| 367 | +
- res <- checkmate::check_character(levels(x), min.chars = 1)+ ) |
|||
| 102 | +368 |
- }+ } |
||
| 103 | +369 | |||
| 104 | -894x | +|||
| 370 | +
- return(res)+ #' @describeIn extreme_format Internal helper function to apply a threshold format to a value. |
|||
| 105 | +371 |
- }+ #' Creates a formatted string to be used in Formatting Functions. |
||
| 106 | +372 |
- #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty+ #' |
||
| 107 | +373 |
- #' string levels). Note that `NULL` and `NA` elements are allowed.+ #' @param x (`number`)\cr value to format. |
||
| 108 | +374 |
#' |
||
| 109 | +375 |
- #' @keywords internal+ #' @return |
||
| 110 | +376 |
- assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)+ #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation |
||
| 111 | +377 |
-
+ #' of the given value to the digit threshold, as a formatted string. |
||
| 112 | +378 |
-
+ #' |
||
| 113 | +379 |
- check_df_with_factors <- function(df,+ #' @examples |
||
| 114 | +380 |
- variables,+ #' h_format_threshold(0.001) |
||
| 115 | +381 |
- min.levels = 1, # nolint+ #' h_format_threshold(1000) |
||
| 116 | +382 |
- max.levels = NULL, # nolint+ #' |
||
| 117 | +383 |
- any.missing = TRUE, # nolint+ #' @export |
||
| 118 | +384 |
- na_level = NULL) {
+ h_format_threshold <- function(x, digits = 2L) {
|
||
| 119 | -206x | +385 | +1501x |
- res <- check_df_with_variables(df, variables, na_level)+ if (is.na(x)) {
+ |
+
| 386 | +4x | +
+ return(x) |
||
| 120 | +387 |
- # checking if all the columns specified by variables are valid factors+ }+ |
+ ||
| 388 | ++ | + | ||
| 121 | -205x | +389 | +1497x |
- if (isTRUE(res)) {
+ checkmate::assert_numeric(x, lower = 0) |
| 122 | +390 |
- # searching the data.frame with selected columns (variables) as a list+ |
||
| 123 | -203x | +391 | +1497x |
- res <- lapply(+ l_fmt <- h_get_format_threshold(digits) |
| 124 | -203x | +|||
| 392 | +
- X = as.list(df)[unlist(variables)],+ |
|||
| 125 | -203x | +393 | +1497x |
- FUN = check_valid_factor,+ result <- if (x < l_fmt$threshold["low"] && 0 < x) {
|
| 126 | -203x | +394 | +33x |
- min.levels = min.levels,+ l_fmt$format_string["low"] |
| 127 | -203x | +395 | +1497x |
- max.levels = max.levels,+ } else if (x > l_fmt$threshold["high"]) {
|
| 128 | -203x | +396 | +80x |
- any.missing = any.missing+ l_fmt$format_string["high"] |
| 129 | +397 |
- )- |
- ||
| 130 | -203x | -
- res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ } else {
|
||
| 131 | -203x | +398 | +1384x |
- if (any(res_lo)) {
+ sprintf(fmt = paste0("%.", digits, "f"), x)
|
| 132 | -6x | +|||
| 399 | +
- return(paste0(+ } |
|||
| 133 | -6x | +|||
| 400 | +
- deparse(substitute(df)), " does not contain only factor variables among:",+ |
|||
| 134 | -6x | +401 | +1497x |
- "\n* Column `", paste0(unlist(variables)[res_lo],+ unname(result) |
| 135 | -6x | +|||
| 402 | +
- "` of the data.frame -> ", res[res_lo],+ } |
|||
| 136 | -6x | +|||
| 403 | +
- collapse = "\n* "+ |
|||
| 137 | +404 |
- )+ #' Formatting a Single Extreme Value |
||
| 138 | +405 |
- ))+ #' |
||
| 139 | +406 |
- } else {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 140 | -197x | +|||
| 407 | +
- res <- TRUE+ #' |
|||
| 141 | +408 |
- }+ #' Create Formatting Function for a single extreme value. |
||
| 142 | +409 |
- }+ #' |
||
| 143 | -199x | +|||
| 410 | +
- return(res)+ #' @inheritParams extreme_format |
|||
| 144 | +411 |
- }+ #' |
||
| 145 | +412 |
- #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value. |
||
| 146 | +413 |
- #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ #' |
||
| 147 | +414 |
- #' trim `NA` levels out of the vector list itself.+ #' @examples |
||
| 148 | +415 |
- #'+ #' format_fun <- format_extreme_values(2L) |
||
| 149 | +416 |
- #' @keywords internal+ #' format_fun(x = 0.127) |
||
| 150 | +417 |
- assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)+ #' format_fun(x = Inf) |
||
| 151 | +418 |
-
+ #' format_fun(x = 0) |
||
| 152 | +419 |
- #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.+ #' format_fun(x = 0.009) |
||
| 153 | +420 |
#' |
||
| 154 | +421 |
- #' @keywords internal+ #' @family formatting functions |
||
| 155 | +422 |
- assert_proportion_value <- function(x, include_boundaries = FALSE) {
+ #' @export |
||
| 156 | -7476x | +|||
| 423 | +
- checkmate::assert_number(x, lower = 0, upper = 1)+ format_extreme_values <- function(digits = 2L) {
|
|||
| 157 | -7464x | +424 | +31x |
- checkmate::assert_flag(include_boundaries)+ function(x, ...) {
|
| 158 | -7464x | +425 | +423x |
- if (isFALSE(include_boundaries)) {
+ checkmate::assert_scalar(x, na.ok = TRUE) |
| 159 | -3407x | +|||
| 426 | +
- checkmate::assert_true(x > 0)+ |
|||
| 160 | -3405x | +427 | +423x |
- checkmate::assert_true(x < 1)+ h_format_threshold(x = x, digits = digits) |
| 161 | +428 |
} |
||
| 162 | +429 |
} |
| 1 | -- |
- #' Horizontal Waterfall Plot- |
- ||
| 2 | +430 |
- #'+ |
||
| 3 | +431 |
- #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup.+ #' Formatting Extreme Values Part of a Confidence Interval |
||
| 4 | +432 |
#' |
||
| 5 | +433 |
#' @description `r lifecycle::badge("stable")`
|
||
| 6 | +434 |
#' |
||
| 7 | +435 |
- #' @param height (`numeric``)\cr vector containing values to be plotted as the waterfall bars.+ #' Formatting Function for extreme values part of a confidence interval. Values |
||
| 8 | +436 |
- #' @param id (`character`)\cr vector containing IDs to use as the x-axis label for the waterfall bars.+ #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2. |
||
| 9 | +437 |
- #' @param col (`character`)\cr colors.+ #' |
||
| 10 | +438 |
- #' @param col_var (`factor`, `character` or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.+ #' @inheritParams extreme_format |
||
| 11 | +439 |
- #' @param xlab (`character`)\cr x label. Default is `"ID"`.+ #' |
||
| 12 | +440 |
- #' @param ylab (`character`)\cr y label. Default is `"Value"`.+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme |
||
| 13 | +441 |
- #' @param title (`character`)\cr text to be displayed as plot title.+ #' values confidence interval. |
||
| 14 | +442 |
- #' @param col_legend_title (`character`)\cr text to be displayed as legend title.+ #' |
||
| 15 | +443 |
- #'+ #' @examples |
||
| 16 | +444 |
- #' @return A `ggplot` waterfall plot.+ #' format_fun <- format_extreme_values_ci(2L) |
||
| 17 | +445 |
- #'+ #' format_fun(x = c(0.127, Inf)) |
||
| 18 | +446 |
- #' @examples+ #' format_fun(x = c(0, 0.009)) |
||
| 19 | +447 |
- #' library(dplyr)+ #' |
||
| 20 | +448 |
- #' library(nestcolor)+ #' @family formatting functions |
||
| 21 | +449 |
- #'+ #' @export |
||
| 22 | +450 |
- #' g_waterfall(height = c(3, 5, -1), id = letters[1:3])+ format_extreme_values_ci <- function(digits = 2L) {
|
||
| 23 | -+ | |||
| 451 | +39x |
- #'+ function(x, ...) {
|
||
| 24 | -+ | |||
| 452 | +536x |
- #' g_waterfall(+ checkmate::assert_vector(x, len = 2) |
||
| 25 | -+ | |||
| 453 | +536x |
- #' height = c(3, 5, -1),+ l_result <- h_format_threshold(x = x[1], digits = digits) |
||
| 26 | -+ | |||
| 454 | +536x |
- #' id = letters[1:3],+ h_result <- h_format_threshold(x = x[2], digits = digits) |
||
| 27 | +455 |
- #' col_var = letters[1:3]+ + |
+ ||
| 456 | +536x | +
+ paste0("(", l_result, ", ", h_result, ")")
|
||
| 28 | +457 |
- #' )+ } |
||
| 29 | +458 |
- #'+ } |
||
| 30 | +459 |
- #' adsl_f <- tern_ex_adsl %>%+ |
||
| 31 | +460 |
- #' select(USUBJID, STUDYID, ARM, ARMCD, SEX)+ #' Automatic formats from data significant digits |
||
| 32 | +461 |
#' |
||
| 33 | +462 |
- #' adrs_f <- tern_ex_adrs %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 34 | +463 |
- #' filter(PARAMCD == "OVRINV") %>%+ #' |
||
| 35 | +464 |
- #' mutate(pchg = rnorm(n(), 10, 50))+ #' Formatting function for the majority of default methods used in [analyze_vars()]. |
||
| 36 | +465 |
- #'+ #' For non-derived values, the significant digits of data is used (e.g. range), while derived |
||
| 37 | +466 |
- #' adrs_f <- head(adrs_f, 30)+ #' values have one more digits (measure of location and dispersion like mean, standard deviation). |
||
| 38 | +467 |
- #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]+ #' This function can be called internally with "auto" like, for example, |
||
| 39 | +468 |
- #' head(adrs_f)+ #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
|
||
| 40 | +469 |
#' |
||
| 41 | +470 |
- #' g_waterfall(+ #' @param dt_var (`numeric`) \cr all the data the statistics was created upon. Used only to find |
||
| 42 | +471 |
- #' height = adrs_f$pchg,+ #' significant digits. In [analyze_vars] this comes from `.df_row` (see |
||
| 43 | +472 |
- #' id = adrs_f$USUBJID,+ #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No |
||
| 44 | +473 |
- #' col_var = adrs_f$AVALC+ #' column split is considered. |
||
| 45 | +474 |
- #' )+ #' @param x_stat (`string`) \cr string indicating the current statistical method used. |
||
| 46 | +475 |
#' |
||
| 47 | +476 |
- #' g_waterfall(+ #' @return A string that `rtables` prints in a table cell. |
||
| 48 | +477 |
- #' height = adrs_f$pchg,+ #' |
||
| 49 | +478 |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ #' @details |
||
| 50 | +479 |
- #' col_var = adrs_f$SEX+ #' The internal function is needed to work with `rtables` default structure for |
||
| 51 | +480 |
- #' )+ #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation. |
||
| 52 | +481 |
- #'+ #' It can be more than one element (e.g. for `.stats = "mean_sd"`). |
||
| 53 | +482 |
- #' g_waterfall(+ #' |
||
| 54 | +483 |
- #' height = adrs_f$pchg,+ #' @examples |
||
| 55 | +484 |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4) |
||
| 56 | +485 |
- #' xlab = "ID",+ #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3])) |
||
| 57 | +486 |
- #' ylab = "Percentage Change",+ #' |
||
| 58 | +487 |
- #' title = "Waterfall plot"+ #' # x is the result coming into the formatting function -> res!! |
||
| 59 | +488 |
- #' )+ #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res) |
||
| 60 | +489 |
- #'+ #' format_auto(x_todo, "range")(x = range(x_todo)) |
||
| 61 | +490 |
- #' @export+ #' no_sc_x <- c(0.0000001, 1) |
||
| 62 | +491 |
- g_waterfall <- function(height,+ #' format_auto(no_sc_x, "range")(x = no_sc_x) |
||
| 63 | +492 |
- id,+ #' |
||
| 64 | +493 |
- col_var = NULL,+ #' @family formatting functions |
||
| 65 | +494 |
- col = getOption("ggplot2.discrete.colour"),
+ #' @export |
||
| 66 | +495 |
- xlab = NULL,+ format_auto <- function(dt_var, x_stat) {
|
||
| 67 | -+ | |||
| 496 | +8x |
- ylab = NULL,+ function(x = "", ...) {
|
||
| 68 | -+ | |||
| 497 | +12x |
- col_legend_title = NULL,+ checkmate::assert_numeric(x, min.len = 1)+ |
+ ||
| 498 | +12x | +
+ checkmate::assert_numeric(dt_var, min.len = 1) |
||
| 69 | +499 |
- title = NULL) {
+ # Defaults - they may be a param in the future |
||
| 70 | -2x | +500 | +12x |
- if (!is.null(col_var)) {
+ der_stats <- c( |
| 71 | -1x | +501 | +12x |
- check_same_n(height = height, id = id, col_var = col_var)+ "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",+ |
+
| 502 | +12x | +
+ "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi",+ |
+ ||
| 503 | +12x | +
+ "median_ci" |
||
| 72 | +504 |
- } else {
+ ) |
||
| 73 | -1x | +505 | +12x |
- check_same_n(height = height, id = id)+ nonder_stats <- c("n", "range", "min", "max")
|
| 74 | +506 |
- }+ |
||
| 75 | +507 |
-
+ # Safenet for miss-modifications |
||
| 76 | -2x | +508 | +12x |
- checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
+ stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint |
| 77 | -2x | +509 | +12x |
- checkmate::assert_character(col, null.ok = TRUE)+ checkmate::assert_choice(x_stat, c(der_stats, nonder_stats)) |
| 78 | +510 | |||
| 511 | ++ |
+ # Finds the max number of digits in data+ |
+ ||
| 79 | -2x | +512 | +12x |
- xlabel <- deparse(substitute(id))+ detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>% |
| 80 | -2x | +513 | +12x |
- ylabel <- deparse(substitute(height))+ max() |
| 81 | +514 | |||
| 82 | -2x | +515 | +12x |
- col_label <- if (!missing(col_var)) {
+ if (x_stat %in% der_stats) {
|
| 83 | -1x | +516 | +5x |
- deparse(substitute(col_var))+ detect_dig <- detect_dig + 1 |
| 84 | +517 |
- }+ } |
||
| 85 | +518 | |||
| 519 | ++ |
+ # Render input+ |
+ ||
| 86 | -2x | +520 | +12x |
- xlab <- if (is.null(xlab)) xlabel else xlab+ str_vals <- formatC(x, digits = detect_dig, format = "f") |
| 87 | -2x | +521 | +12x |
- ylab <- if (is.null(ylab)) ylabel else ylab+ def_fmt <- get_formats_from_stats(x_stat)[[x_stat]] |
| 88 | -2x | +522 | +12x |
- col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title+ str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]] |
| 89 | -+ | |||
| 523 | +12x |
-
+ if (length(str_fmt) != length(str_vals)) {
|
||
| 90 | +524 | 2x |
- plot_data <- data.frame(+ stop( |
|
| 91 | +525 | 2x |
- height = height,+ "Number of inserted values as result (", length(str_vals),
|
|
| 92 | +526 | 2x |
- id = as.character(id),+ ") is not the same as there should be in the default tern formats for ", |
|
| 93 | +527 | 2x |
- col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),+ x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ", |
|
| 94 | +528 | 2x |
- stringsAsFactors = FALSE+ "See tern_default_formats to check all of them." |
|
| 95 | +529 |
- )+ ) |
||
| 96 | +530 | ++ |
+ }+ |
+ |
| 531 | ||||
| 532 | ++ |
+ # Squashing them together+ |
+ ||
| 97 | -2x | +533 | +10x |
- plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]+ inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]+ |
+
| 534 | +10x | +
+ stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint |
||
| 98 | +535 | |||
| 99 | -2x | +536 | +10x |
- p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) ++ out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
|
| 100 | -2x | +537 | +10x |
- ggplot2::geom_col() ++ is_even <- seq_along(out) %% 2 == 0 |
| 101 | -2x | +538 | +10x |
- ggplot2::geom_text(+ out[is_even] <- str_vals |
| 102 | -2x | +539 | +10x |
- label = format(plot_data_ord$height, digits = 2),+ out[!is_even] <- inv_str_fmt+ |
+
| 540 | ++ | + | ||
| 103 | -2x | +541 | +10x |
- vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)+ return(paste0(out, collapse = "")) |
| 104 | +542 |
- ) ++ } |
||
| 105 | -2x | +|||
| 543 | +
- ggplot2::xlab(xlab) ++ } |
|||
| 106 | -2x | +|||
| 544 | +
- ggplot2::ylab(ylab) ++ |
|||
| 107 | -2x | +|||
| 545 | +
- ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))+ # Utility function that could be useful in general |
|||
| 108 | +546 |
-
+ str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
|
||
| 109 | -2x | +547 | +22x |
- if (!is.null(col_var)) {
+ regmatches(string, gregexpr(pattern, string), invert = invert) |
| 110 | -1x | +|||
| 548 | +
- p <- p ++ } |
|||
| 111 | -1x | +|||
| 549 | +
- ggplot2::aes(fill = col_var) ++ |
|||
| 112 | -1x | +|||
| 550 | +
- ggplot2::labs(fill = col_legend_title) ++ # Helper function |
|||
| 113 | -1x | +|||
| 551 | +
- ggplot2::theme(+ count_decimalplaces <- function(dec) {
|
|||
| 114 | -1x | +552 | +125x |
- legend.position = "bottom",+ if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
|
| 115 | -1x | +553 | +104x |
- legend.background = ggplot2::element_blank(),+ nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]]) |
| 116 | -1x | +|||
| 554 | +
- legend.title = ggplot2::element_text(face = "bold"),+ } else {
|
|||
| 117 | -1x | +555 | +21x |
- legend.box.background = ggplot2::element_rect(colour = "black")+ return(0) |
| 118 | +556 |
- )+ } |
||
| 119 | +557 |
- }+ } |
||
| 120 | +558 | |||
| 121 | -2x | +|||
| 559 | +
- if (!is.null(col)) {
+ #' Apply Auto Formatting |
|||
| 122 | -1x | +|||
| 560 | +
- p <- p ++ #' |
|||
| 123 | -1x | +|||
| 561 | +
- ggplot2::scale_fill_manual(values = col)+ #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with |
|||
| 124 | +562 |
- }+ #' the correct implementation of `format_auto` for the given statistics, data, and variable. |
||
| 125 | +563 |
-
+ #'+ |
+ ||
| 564 | ++ |
+ #' @inheritParams argument_convention+ |
+ ||
| 565 | ++ |
+ #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds+ |
+ ||
| 566 | ++ |
+ #' to an element in `.formats`, with matching names.+ |
+ ||
| 567 | ++ |
+ #'+ |
+ ||
| 568 | ++ |
+ #' @keywords internal+ |
+ ||
| 569 | ++ |
+ apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
|
||
| 126 | -2x | +570 | +385x |
- if (!is.null(title)) {
+ is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1)) |
| 127 | -1x | +571 | +385x |
- p <- p ++ if (any(is_auto_fmt)) {
|
| 128 | -1x | +572 | +2x |
- ggplot2::labs(title = title) ++ auto_stats <- x_stats[is_auto_fmt] |
| 129 | -1x | +573 | +2x |
- ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))+ var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets |
| 130 | -+ | |||
| 574 | +2x |
- }+ .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df) |
||
| 131 | +575 |
-
+ } |
||
| 132 | -2x | +576 | +385x |
- p+ .formats |
| 133 | +577 |
}@@ -156291,7486 +158677,6632 @@ tern coverage - 90.46% |
||
| 277 | -- |
- }- |
-
| 1 | -- |
- #' Patient Counts with Abnormal Range Values by Baseline Status- |
- |
| 2 | -- |
- #'- |
- |
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- |
| 4 | -- |
- #'- |
- |
| 5 | -- |
- #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`), and additional- |
- |
| 6 | -- |
- #' analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or `factor`). For each- |
- |
| 7 | -- |
- #' direction specified in `abnormal` (e.g. high or low) we condition on baseline range result and count- |
- |
| 8 | -- |
- #' patients in the numerator and denominator as follows:- |
- |
| 9 | -- |
- #' * `Not <Abnormal>`- |
- |
| 10 | -- |
- #' * `denom`: the number of patients without abnormality at baseline (excluding those with missing baseline)- |
- |
| 11 | -- |
- #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline- |
- |
| 12 | -- |
- #' * `<Abnormal>`- |
- |
| 13 | -- |
- #' * `denom`: the number of patients with abnormality at baseline- |
- |
| 14 | -- |
- #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline- |
- |
| 15 | -- |
- #' * `Total`- |
- |
| 16 | -- |
- #' * `denom`: the number of patients with at least one valid measurement post-baseline- |
- |
| 17 | -- |
- #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline- |
- |
| 18 | -- |
- #'- |
- |
| 19 | -- |
- #' @inheritParams argument_convention- |
- |
| 20 | -- |
- #' @param abnormal (`character`)\cr identifying the abnormal range level(s) in `.var`.- |
- |
| 21 | -- |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_baseline")`
- |
- |
| 22 | -- |
- #' to see available statistics for this function.- |
- |
| 23 | -- |
- #'- |
- |
| 24 | -- |
- #' @note- |
- |
| 25 | -- |
- #' * `df` should be filtered to include only post-baseline records.- |
- |
| 26 | -- |
- #' * If the baseline variable or analysis variable contains `NA`, it is expected that `NA` has been- |
- |
| 27 | -- |
- #' conveyed to `na_level` appropriately beforehand with [df_explicit_na()] or [explicit_na()].- |
- |
| 28 | -- |
- #'- |
- |
| 29 | -- |
- #' @seealso Relevant description function [d_count_abnormal_by_baseline()].- |
- |
| 30 | -- |
- #'- |
- |
| 31 | -- |
- #' @name abnormal_by_baseline- |
- |
| 32 | -- |
- #' @order 1- |
- |
| 33 | -- |
- NULL- |
- |
| 34 | -- | - - | -|
| 35 | -- |
- #' Description Function for [s_count_abnormal_by_baseline()]- |
- |
| 36 | -- |
- #'- |
- |
| 37 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- |
| 38 | -- |
- #'- |
- |
| 39 | -- |
- #' Description function that produces the labels for [s_count_abnormal_by_baseline()].- |
- |
| 40 | -- |
- #'- |
- |
| 41 | -- |
- #' @inheritParams abnormal_by_baseline- |
- |
| 42 | -- |
- #'- |
- |
| 43 | -- |
- #' @return Abnormal category labels for [s_count_abnormal_by_baseline()].- |
- |
| 44 | -- |
- #'- |
- |
| 45 | -- |
- #' @examples- |
- |
| 46 | -- |
- #' d_count_abnormal_by_baseline("LOW")
- |
- |
| 47 | -- |
- #'- |
- |
| 48 | -- |
- #' @export- |
- |
| 49 | -- |
- d_count_abnormal_by_baseline <- function(abnormal) {
- |
- |
| 50 | -7x | -
- not_abn_name <- paste("Not", tolower(abnormal))
- |
- |
| 51 | -7x | -
- abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))- |
- |
| 52 | -7x | -
- total_name <- "Total"- |
- |
| 53 | -- | - - | -|
| 54 | -7x | -
- list(- |
- |
| 55 | -7x | -
- not_abnormal = not_abn_name,- |
- |
| 56 | -7x | -
- abnormal = abn_name,- |
- |
| 57 | -7x | -
- total = total_name- |
- |
| 58 | -- |
- )- |
- |
| 59 | -- |
- }- |
- |
| 60 | -- | - - | -|
| 61 | -- |
- #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level.- |
- |
| 62 | -- |
- #'- |
- |
| 63 | -- |
- #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with- |
- |
| 64 | -- |
- #' [df_explicit_na()]). The default is `"<Missing>"`.- |
- |
| 65 | -- |
- #'- |
- |
| 66 | -- |
- #' @return- |
- |
| 67 | -- |
- #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements:- |
- |
| 68 | -- |
- #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts.- |
- |
| 69 | -- |
- #'- |
- |
| 70 | -- |
- #' @keywords internal- |
- |
| 71 | -- |
- s_count_abnormal_by_baseline <- function(df,- |
- |
| 72 | -- |
- .var,- |
- |
| 73 | -- |
- abnormal,- |
- |
| 74 | -- |
- na_level = lifecycle::deprecated(),- |
- |
| 75 | -- |
- na_str = "<Missing>",- |
- |
| 76 | -- |
- variables = list(id = "USUBJID", baseline = "BNRIND")) {
- |
- |
| 77 | -5x | -
- if (lifecycle::is_present(na_level)) {
- |
- |
| 78 | -! | -
- lifecycle::deprecate_warn("0.9.1", "s_count_abnormal_by_baseline(na_level)", "s_count_abnormal_by_baseline(na_str)")
- |
- |
| 79 | -! | -
- na_str <- na_level- |
- |
| 80 | -- |
- }- |
- |
| 81 | -- | - - | -|
| 82 | -5x | -
- checkmate::assert_string(.var)- |
- |
| 83 | -5x | -
- checkmate::assert_string(abnormal)- |
- |
| 84 | -5x | -
- checkmate::assert_string(na_str)- |
- |
| 85 | -5x | -
- assert_df_with_variables(df, c(range = .var, variables))- |
- |
| 86 | -5x | -
- checkmate::assert_subset(names(variables), c("id", "baseline"))
- |
- |
| 87 | -5x | -
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
- |
- |
| 88 | -5x | -
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
- |
- |
| 89 | -5x | -
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
- |
- |
| 90 | -- | - - | -|
| 91 | -- |
- # If input is passed as character, changed to factor- |
- |
| 92 | -5x | -
- df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str)- |
- |
| 93 | -5x | -
- df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str)- |
- |
| 94 | -- | - - | -|
| 95 | -5x | -
- assert_valid_factor(df[[.var]], any.missing = FALSE)- |
- |
| 96 | -4x | -
- assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)- |
- |
| 97 | -- | - - | -|
| 98 | -- |
- # Keep only records with valid analysis value.- |
- |
| 99 | -3x | -
- df <- df[df[[.var]] != na_str, ]- |
- |
| 100 | -- | - - | -|
| 101 | -3x | -
- anl <- data.frame(- |
- |
| 102 | -3x | -
- id = df[[variables$id]],- |
- |
| 103 | -3x | -
- var = df[[.var]],- |
- |
| 104 | -3x | -
- baseline = df[[variables$baseline]],- |
- |
| 105 | -3x | -
- stringsAsFactors = FALSE- |
- |
| 106 | -- |
- )- |
- |
| 107 | -- | - - | -|
| 108 | -- |
- # Total:- |
- |
| 109 | -- |
- # - Patients in denominator: have at least one valid measurement post-baseline.- |
- |
| 110 | -- |
- # - Patients in numerator: have at least one abnormality.- |
- |
| 111 | -3x | -
- total_denom <- length(unique(anl$id))- |
- |
| 112 | -3x | -
- total_num <- length(unique(anl$id[anl$var == abnormal]))- |
- |
| 113 | -- | - - | -|
| 114 | -- |
- # Baseline NA records are counted only in total rows.- |
- |
| 115 | -3x | -
- anl <- anl[anl$baseline != na_str, ]- |
- |
| 116 | -- | - - | -|
| 117 | -- |
- # Abnormal:- |
- |
| 118 | -- |
- # - Patients in denominator: have abnormality at baseline.- |
- |
| 119 | -- |
- # - Patients in numerator: have abnormality at baseline AND- |
- |
| 120 | -- |
- # have at least one abnormality post-baseline.- |
- |
| 121 | -3x | -
- abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))- |
- |
| 122 | -3x | -
- abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))- |
- |
| 123 | -- | - - | -|
| 124 | -- |
- # Not abnormal:- |
- |
| 125 | -- |
- # - Patients in denominator: do not have abnormality at baseline.- |
- |
| 126 | -- |
- # - Patients in numerator: do not have abnormality at baseline AND- |
- |
| 127 | -- |
- # have at least one abnormality post-baseline.- |
- |
| 128 | -3x | -
- not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))- |
- |
| 129 | -3x | -
- not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))- |
- |
| 130 | -- | - - | -|
| 131 | -3x | -
- labels <- d_count_abnormal_by_baseline(abnormal)- |
- |
| 132 | -3x | -
- list(fraction = list(- |
- |
| 133 | -3x | -
- not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),- |
- |
| 134 | -3x | -
- abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),- |
- |
| 135 | -3x | -
- total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)- |
- |
| 136 | -- |
- ))- |
- |
| 137 | -- |
- }- |
- |
| 138 | -- | - - | -|
| 139 | -- |
- #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun`- |
- |
| 140 | +277 |
- #' in `count_abnormal_by_baseline()`.+ } |
| 141 | +1 |
- #'+ #' Stack Multiple Grobs |
||
| 142 | +2 |
- #' @return+ #' |
||
| 143 | +3 |
- #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 144 | +4 |
#' |
||
| 145 | +5 |
- #' @keywords internal+ #' Stack grobs as a new grob with 1 column and multiple rows layout. |
||
| 146 | +6 |
- a_count_abnormal_by_baseline <- make_afun(+ #' |
||
| 147 | +7 |
- s_count_abnormal_by_baseline,+ #' @param ... grobs. |
||
| 148 | +8 |
- .formats = c(fraction = format_fraction)+ #' @param grobs list of grobs. |
||
| 149 | +9 |
- )+ #' @param padding unit of length 1, space between each grob. |
||
| 150 | +10 |
-
+ #' @param vp a [viewport()] object (or `NULL`). |
||
| 151 | +11 |
- #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments+ #' @param name a character identifier for the grob. |
||
| 152 | +12 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @param gp A [gpar()] object. |
||
| 153 | +13 |
#' |
||
| 154 | +14 |
- #' @return+ #' @return A `grob`. |
||
| 155 | +15 |
- #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 156 | +16 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @examples |
||
| 157 | +17 |
- #' the statistics from `s_count_abnormal_by_baseline()` to the table layout.+ #' library(grid) |
||
| 158 | +18 |
#' |
||
| 159 | +19 |
- #' @examples+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
||
| 160 | +20 |
- #' df <- data.frame(+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
||
| 161 | +21 |
- #' USUBJID = as.character(c(1:6)),+ #' g3 <- textGrob("TEST TEXT")
|
||
| 162 | +22 |
- #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
+ #' grid.newpage() |
||
| 163 | +23 |
- #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
+ #' grid.draw(stack_grobs(g1, g2, g3)) |
||
| 164 | +24 |
- #' )+ #' |
||
| 165 | +25 |
- #' df <- df_explicit_na(df)+ #' showViewport() |
||
| 166 | +26 |
#' |
||
| 167 | +27 |
- #' # Layout creating function.+ #' grid.newpage() |
||
| 168 | +28 |
- #' basic_table() %>%+ #' pushViewport(viewport(layout = grid.layout(1, 2))) |
||
| 169 | +29 |
- #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%+ #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2) |
||
| 170 | +30 |
- #' build_table(df)+ #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test")) |
||
| 171 | +31 |
#' |
||
| 172 | +32 |
- #' # Passing of statistics function and formatting arguments.+ #' showViewport() |
||
| 173 | +33 |
- #' df2 <- data.frame(+ #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE) |
||
| 174 | +34 |
- #' ID = as.character(c(1, 2, 3, 4)),+ #' |
||
| 175 | +35 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' @export |
||
| 176 | +36 |
- #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
+ stack_grobs <- function(..., |
||
| 177 | +37 |
- #' )+ grobs = list(...), |
||
| 178 | +38 |
- #'+ padding = grid::unit(2, "line"), |
||
| 179 | +39 |
- #' basic_table() %>%+ vp = NULL, |
||
| 180 | +40 |
- #' count_abnormal_by_baseline(+ gp = NULL, |
||
| 181 | +41 |
- #' var = "RANGE",+ name = NULL) {
|
||
| 182 | -+ | |||
| 42 | +4x |
- #' abnormal = c(Low = "LOW"),+ checkmate::assert_true( |
||
| 183 | -+ | |||
| 43 | +4x |
- #' variables = list(id = "ID", baseline = "BLRANGE"),+ all(vapply(grobs, grid::is.grob, logical(1))) |
||
| 184 | +44 |
- #' .formats = c(fraction = "xx / xx"),+ ) |
||
| 185 | +45 |
- #' .indent_mods = c(fraction = 2L)+ |
||
| 186 | -+ | |||
| 46 | +4x |
- #' ) %>%+ if (length(grobs) == 1) {
|
||
| 187 | -+ | |||
| 47 | +1x |
- #' build_table(df2)+ return(grobs[[1]]) |
||
| 188 | +48 |
- #'+ } |
||
| 189 | +49 |
- #' @export+ |
||
| 190 | -+ | |||
| 50 | +3x |
- #' @order 2+ n_layout <- 2 * length(grobs) - 1 |
||
| 191 | -+ | |||
| 51 | +3x |
- count_abnormal_by_baseline <- function(lyt,+ hts <- lapply( |
||
| 192 | -+ | |||
| 52 | +3x |
- var,+ seq(1, n_layout), |
||
| 193 | -+ | |||
| 53 | +3x |
- abnormal,+ function(i) {
|
||
| 194 | -+ | |||
| 54 | +39x |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ if (i %% 2 != 0) {
|
||
| 195 | -+ | |||
| 55 | +21x |
- na_str = "<Missing>",+ grid::unit(1, "null") |
||
| 196 | +56 |
- nested = TRUE,+ } else {
|
||
| 197 | -+ | |||
| 57 | +18x |
- ...,+ padding |
||
| 198 | +58 |
- table_names = abnormal,+ } |
||
| 199 | +59 |
- .stats = NULL,+ } |
||
| 200 | +60 |
- .formats = NULL,+ ) |
||
| 201 | -+ | |||
| 61 | +3x |
- .labels = NULL,+ hts <- do.call(grid::unit.c, hts) |
||
| 202 | +62 |
- .indent_mods = NULL) {
+
|
||
| 203 | -2x | +63 | +3x |
- checkmate::assert_character(abnormal, len = length(table_names), names = "named")+ main_vp <- grid::viewport( |
| 204 | -2x | +64 | +3x |
- checkmate::assert_string(var)+ layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts) |
| 205 | +65 | - - | -||
| 206 | -2x | -
- extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...)+ ) |
||
| 207 | +66 | |||
| 208 | -2x | +67 | +3x |
- afun <- make_afun(+ nested_grobs <- Map(function(g, i) {
|
| 209 | -2x | +68 | +21x |
- a_count_abnormal_by_baseline,+ grid::gTree( |
| 210 | -2x | +69 | +21x |
- .stats = .stats,+ children = grid::gList(g), |
| 211 | -2x | +70 | +21x |
- .formats = .formats,+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1) |
| 212 | -2x | +|||
| 71 | +
- .labels = .labels,+ ) |
|||
| 213 | -2x | +72 | +3x |
- .indent_mods = .indent_mods,+ }, grobs, seq_along(grobs) * 2 - 1) |
| 214 | -2x | +|||
| 73 | +
- .ungroup_stats = "fraction"+ |
|||
| 215 | -+ | |||
| 74 | +3x |
- )+ grobs_mainvp <- grid::gTree( |
||
| 216 | -2x | +75 | +3x |
- for (i in seq_along(abnormal)) {
+ children = do.call(grid::gList, nested_grobs), |
| 217 | -4x | +76 | +3x |
- extra_args[["abnormal"]] <- abnormal[i]+ vp = main_vp |
| 218 | +77 | ++ |
+ )+ |
+ |
| 78 | ||||
| 219 | -4x | +79 | +3x |
- lyt <- analyze(+ grid::gTree( |
| 220 | -4x | +80 | +3x |
- lyt = lyt,+ children = grid::gList(grobs_mainvp), |
| 221 | -4x | +81 | +3x |
- vars = var,+ vp = vp, |
| 222 | -4x | +82 | +3x |
- var_labels = names(abnormal[i]),+ gp = gp, |
| 223 | -4x | +83 | +3x |
- afun = afun,+ name = name |
| 224 | -4x | +|||
| 84 | +
- na_str = na_str,+ ) |
|||
| 225 | -4x | +|||
| 85 | +
- nested = nested,+ } |
|||
| 226 | -4x | +|||
| 86 | +
- table_names = table_names[i],+ |
|||
| 227 | -4x | +|||
| 87 | +
- extra_args = extra_args,+ #' Arrange Multiple Grobs |
|||
| 228 | -4x | +|||
| 88 | +
- show_labels = "visible"+ #' |
|||
| 229 | +89 |
- )+ #' Arrange grobs as a new grob with \verb{n*m (rows*cols)} layout.
|
||
| 230 | +90 |
- }+ #' |
||
| 231 | -2x | +|||
| 91 | +
- lyt+ #' @inheritParams stack_grobs |
|||
| 232 | +92 |
- }+ #' @param ncol number of columns in layout. |
| 1 | +93 |
- #' Survival Time Analysis+ #' @param nrow number of rows in layout. |
||
| 2 | +94 |
- #'+ #' @param padding_ht unit of length 1, vertical space between each grob. |
||
| 3 | +95 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param padding_wt unit of length 1, horizontal space between each grob. |
||
| 4 | +96 |
#' |
||
| 5 | +97 |
- #' Summarize median survival time and CIs, percentiles of survival times, survival+ #' @return A `grob`. |
||
| 6 | +98 |
- #' time range of censored/event patients.+ #' @examples |
||
| 7 | +99 | ++ |
+ #' library(grid)+ |
+ |
| 100 |
#' |
|||
| 8 | +101 |
- #' @inheritParams argument_convention+ #' \donttest{
|
||
| 9 | +102 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' num <- lapply(1:9, textGrob) |
||
| 10 | +103 |
- #' [control_surv_time()]. Some possible parameter options are:+ #' grid::grid.newpage() |
||
| 11 | +104 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.+ #' grid.draw(arrange_grobs(grobs = num, ncol = 2)) |
||
| 12 | +105 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log",+ #' |
||
| 13 | +106 |
- #' see more in [survival::survfit()]. Note option "none" is not supported.+ #' showViewport() |
||
| 14 | +107 |
- #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.+ #' |
||
| 15 | +108 |
- #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
||
| 16 | +109 |
- #' when the `range` statistic is included.+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
||
| 17 | +110 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_time")`
+ #' g3 <- textGrob("TEST TEXT")
|
||
| 18 | +111 |
- #' to see available statistics for this function.+ #' grid::grid.newpage() |
||
| 19 | +112 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2)) |
||
| 20 | +113 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' |
||
| 21 | +114 |
- #' for that statistic's row label.+ #' showViewport() |
||
| 22 | +115 |
#' |
||
| 23 | +116 |
- #' @examples+ #' grid::grid.newpage() |
||
| 24 | +117 |
- #' library(dplyr)+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3)) |
||
| 25 | +118 |
#' |
||
| 26 | +119 |
- #' adtte_f <- tern_ex_adtte %>%+ #' grid::grid.newpage() |
||
| 27 | +120 |
- #' filter(PARAMCD == "OS") %>%+ #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2))) |
||
| 28 | +121 |
- #' mutate(+ #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2) |
||
| 29 | +122 |
- #' AVAL = day2month(AVAL),+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1)) |
||
| 30 | +123 |
- #' is_event = CNSR == 0+ #' |
||
| 31 | +124 |
- #' )+ #' showViewport() |
||
| 32 | +125 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' } |
||
| 33 | +126 |
- #'+ #' @export |
||
| 34 | +127 |
- #' @name survival_time+ arrange_grobs <- function(..., |
||
| 35 | +128 |
- #' @order 1+ grobs = list(...), |
||
| 36 | +129 |
- NULL+ ncol = NULL, nrow = NULL, |
||
| 37 | +130 |
-
+ padding_ht = grid::unit(2, "line"), |
||
| 38 | +131 |
- #' @describeIn survival_time Statistics function which analyzes survival times.+ padding_wt = grid::unit(2, "line"), |
||
| 39 | +132 |
- #'+ vp = NULL, |
||
| 40 | +133 |
- #' @return+ gp = NULL, |
||
| 41 | +134 |
- #' * `s_surv_time()` returns the statistics:+ name = NULL) {
+ |
+ ||
| 135 | +5x | +
+ checkmate::assert_true(+ |
+ ||
| 136 | +5x | +
+ all(vapply(grobs, grid::is.grob, logical(1))) |
||
| 42 | +137 |
- #' * `median`: Median survival time.+ ) |
||
| 43 | +138 |
- #' * `median_ci`: Confidence interval for median time.+ + |
+ ||
| 139 | +5x | +
+ if (length(grobs) == 1) {
+ |
+ ||
| 140 | +1x | +
+ return(grobs[[1]]) |
||
| 44 | +141 |
- #' * `quantiles`: Survival time for two specified quantiles.+ } |
||
| 45 | +142 |
- #' * `range_censor`: Survival time range for censored observations.+ + |
+ ||
| 143 | +4x | +
+ if (is.null(ncol) && is.null(nrow)) {
+ |
+ ||
| 144 | +1x | +
+ ncol <- 1+ |
+ ||
| 145 | +1x | +
+ nrow <- ceiling(length(grobs) / ncol)+ |
+ ||
| 146 | +3x | +
+ } else if (!is.null(ncol) && is.null(nrow)) {
+ |
+ ||
| 147 | +1x | +
+ nrow <- ceiling(length(grobs) / ncol)+ |
+ ||
| 148 | +2x | +
+ } else if (is.null(ncol) && !is.null(nrow)) {
+ |
+ ||
| 149 | +! | +
+ ncol <- ceiling(length(grobs) / nrow) |
||
| 46 | +150 |
- #' * `range_event`: Survival time range for observations with events.+ } |
||
| 47 | +151 |
- #' * `range`: Survival time range for all observations.+ + |
+ ||
| 152 | +4x | +
+ if (ncol * nrow < length(grobs)) {
+ |
+ ||
| 153 | +1x | +
+ stop("specififed ncol and nrow are not enough for arranging the grobs ")
|
||
| 48 | +154 |
- #'+ } |
||
| 49 | +155 |
- #' @keywords internal+ + |
+ ||
| 156 | +3x | +
+ if (ncol == 1) {
+ |
+ ||
| 157 | +2x | +
+ return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name)) |
||
| 50 | +158 |
- s_surv_time <- function(df,+ } |
||
| 51 | +159 |
- .var,+ + |
+ ||
| 160 | +1x | +
+ n_col <- 2 * ncol - 1+ |
+ ||
| 161 | +1x | +
+ n_row <- 2 * nrow - 1+ |
+ ||
| 162 | +1x | +
+ hts <- lapply(+ |
+ ||
| 163 | +1x | +
+ seq(1, n_row),+ |
+ ||
| 164 | +1x | +
+ function(i) {
+ |
+ ||
| 165 | +5x | +
+ if (i %% 2 != 0) {
+ |
+ ||
| 166 | +3x | +
+ grid::unit(1, "null") |
||
| 52 | +167 |
- is_event,+ } else {
+ |
+ ||
| 168 | +2x | +
+ padding_ht |
||
| 53 | +169 |
- control = control_surv_time()) {
+ }+ |
+ ||
| 170 | ++ |
+ }+ |
+ ||
| 171 | ++ |
+ ) |
||
| 54 | -182x | +172 | +1x |
- checkmate::assert_string(.var)+ hts <- do.call(grid::unit.c, hts)+ |
+
| 173 | ++ | + | ||
| 55 | -182x | +174 | +1x |
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ wts <- lapply( |
| 56 | -182x | +175 | +1x |
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ seq(1, n_col), |
| 57 | -182x | +176 | +1x |
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ function(i) {
+ |
+
| 177 | +5x | +
+ if (i %% 2 != 0) {
+ |
+ ||
| 178 | +3x | +
+ grid::unit(1, "null") |
||
| 58 | +179 |
-
+ } else {
|
||
| 59 | -182x | +180 | +2x |
- conf_type <- control$conf_type+ padding_wt+ |
+
| 181 | ++ |
+ }+ |
+ ||
| 182 | ++ |
+ }+ |
+ ||
| 183 | ++ |
+ ) |
||
| 60 | -182x | +184 | +1x |
- conf_level <- control$conf_level+ wts <- do.call(grid::unit.c, wts)+ |
+
| 185 | ++ | + | ||
| 61 | -182x | +186 | +1x |
- quantiles <- control$quantiles+ main_vp <- grid::viewport(+ |
+
| 187 | +1x | +
+ layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts) |
||
| 62 | +188 | ++ |
+ )+ |
+ |
| 189 | ||||
| 63 | -182x | +190 | +1x |
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ nested_grobs <- list() |
| 64 | -182x | +191 | +1x |
- srv_fit <- survival::survfit(+ k <- 0 |
| 65 | -182x | +192 | +1x | +
+ for (i in seq(nrow) * 2 - 1) {
+ |
+
| 193 | +3x | +
+ for (j in seq(ncol) * 2 - 1) {
+ |
+ ||
| 194 | +9x | +
+ k <- k + 1+ |
+ ||
| 195 | +9x |
- formula = formula,+ if (k <= length(grobs)) {
|
||
| 66 | -182x | +196 | +9x |
- data = df,+ nested_grobs <- c( |
| 67 | -182x | +197 | +9x |
- conf.int = conf_level,+ nested_grobs, |
| 68 | -182x | +198 | +9x |
- conf.type = conf_type+ list(grid::gTree( |
| 69 | -+ | |||
| 199 | +9x |
- )+ children = grid::gList(grobs[[k]]), |
||
| 70 | -182x | +200 | +9x |
- srv_tab <- summary(srv_fit, extend = TRUE)$table+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = j) |
| 71 | -182x | +|||
| 201 | +
- srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile+ )) |
|||
| 72 | -182x | +|||
| 202 | +
- range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)+ ) |
|||
| 73 | -182x | +|||
| 203 | +
- range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)+ } |
|||
| 74 | -182x | +|||
| 204 | +
- range <- range_noinf(df[[.var]], na.rm = TRUE)+ } |
|||
| 75 | -182x | +|||
| 205 | +
- list(+ } |
|||
| 76 | -182x | +206 | +1x |
- median = formatters::with_label(unname(srv_tab["median"]), "Median"),+ grobs_mainvp <- grid::gTree( |
| 77 | -182x | +207 | +1x |
- median_ci = formatters::with_label(+ children = do.call(grid::gList, nested_grobs), |
| 78 | -182x | +208 | +1x |
- unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
+ vp = main_vp |
| 79 | +209 |
- ),+ ) |
||
| 80 | -182x | +|||
| 210 | +
- quantiles = formatters::with_label(+ |
|||
| 81 | -182x | +211 | +1x |
- unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")+ grid::gTree( |
| 82 | -+ | |||
| 212 | +1x |
- ),+ children = grid::gList(grobs_mainvp), |
||
| 83 | -182x | +213 | +1x |
- range_censor = formatters::with_label(range_censor, "Range (censored)"),+ vp = vp, |
| 84 | -182x | +214 | +1x |
- range_event = formatters::with_label(range_event, "Range (event)"),+ gp = gp, |
| 85 | -182x | +215 | +1x |
- range = formatters::with_label(range, "Range")+ name = name |
| 86 | +216 |
) |
||
| 87 | +217 |
} |
||
| 88 | +218 | |||
| 89 | +219 |
- #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`.+ #' Draw `grob` |
||
| 90 | +220 |
#' |
||
| 91 | +221 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
||
| 92 | +222 |
- #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 93 | +223 |
- #'+ #' Draw grob on device page. |
||
| 94 | +224 |
- #' @examples+ #' |
||
| 95 | +225 |
- #' a_surv_time(+ #' @param grob grid object |
||
| 96 | +226 |
- #' df,+ #' @param newpage draw on a new page |
||
| 97 | +227 |
- #' .df_row = df,+ #' @param vp a [viewport()] object (or `NULL`). |
||
| 98 | +228 |
- #' .var = "AVAL",+ #' |
||
| 99 | +229 |
- #' is_event = "is_event"+ #' @return A `grob`. |
||
| 100 | +230 |
- #' )+ #' |
||
| 101 | +231 |
- #'+ #' @examples |
||
| 102 | +232 |
- #' @export+ #' library(dplyr) |
||
| 103 | +233 |
- a_surv_time <- function(df,+ #' library(grid) |
||
| 104 | +234 |
- labelstr = "",+ #' |
||
| 105 | +235 |
- .var = NULL,+ #' \donttest{
|
||
| 106 | +236 |
- .df_row = NULL,+ #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc")) |
||
| 107 | +237 |
- is_event,+ #' rect %>% draw_grob(vp = grid::viewport(angle = 45)) |
||
| 108 | +238 |
- control = control_surv_time(),+ #' |
||
| 109 | +239 |
- ref_fn_censor = TRUE,+ #' num <- lapply(1:10, textGrob) |
||
| 110 | +240 |
- .stats = NULL,+ #' num %>% |
||
| 111 | +241 |
- .formats = NULL,+ #' arrange_grobs(grobs = .) %>% |
||
| 112 | +242 |
- .labels = NULL,+ #' draw_grob() |
||
| 113 | +243 |
- .indent_mods = NULL,+ #' showViewport() |
||
| 114 | +244 |
- na_str = default_na_str()) {
+ #' } |
||
| 115 | -12x | +|||
| 245 | +
- x_stats <- s_surv_time(+ #' |
|||
| 116 | -12x | +|||
| 246 | +
- df = df, .var = .var, is_event = is_event, control = control+ #' @export |
|||
| 117 | +247 |
- )+ draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
|
||
| 118 | -12x | +248 | +3x |
- rng_censor_lwr <- x_stats[["range_censor"]][1]+ if (newpage) {
|
| 119 | -12x | -
- rng_censor_upr <- x_stats[["range_censor"]][2]- |
- ||
| 120 | -+ | 249 | +3x |
-
+ grid::grid.newpage() |
| 121 | +250 |
- # Use method-specific defaults+ } |
||
| 122 | -12x | +251 | +3x |
- fmts <- c(median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x")+ if (!is.null(vp)) {
|
| 123 | -12x | +252 | +1x |
- lbls <- c(median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)")+ grid::pushViewport(vp) |
| 124 | -12x | +|||
| 253 | +
- lbls_custom <- .labels+ } |
|||
| 125 | -12x | +254 | +3x |
- .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))])+ grid::grid.draw(grob) |
| 126 | -12x | +|||
| 255 | +
- .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))])+ } |
|||
| 127 | +256 | |||
| 128 | +257 |
- # Fill in with formatting defaults if needed- |
- ||
| 129 | -12x | -
- .stats <- get_stats("surv_time", stats_in = .stats)
- |
- ||
| 130 | -12x | -
- .formats <- get_formats_from_stats(.stats, .formats)+ tern_grob <- function(x) {
|
||
| 131 | -12x | +|||
| 258 | +! |
- .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom)+ class(x) <- unique(c("ternGrob", class(x)))
|
||
| 132 | -12x | +|||
| 259 | +! |
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ x |
||
| 133 | +260 | - - | -||
| 134 | -12x | -
- x_stats <- x_stats[.stats]+ } |
||
| 135 | +261 | |||
| 136 | +262 |
- # Auto format handling- |
- ||
| 137 | -12x | -
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' @keywords internal |
||
| 138 | +263 | - - | -||
| 139 | -12x | -
- cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
+ print.ternGrob <- function(x, ...) {
|
||
| 140 | -12x | +|||
| 264 | +! |
- if ("range" %in% names(x_stats) && ref_fn_censor) {
+ grid::grid.newpage() |
||
| 141 | -12x | +|||
| 265 | +! |
- if (x_stats[["range"]][1] == rng_censor_lwr && x_stats[["range"]][2] == rng_censor_upr) {
+ grid::grid.draw(x) |
||
| 142 | -1x | +|||
| 266 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum"+ } |
|||
| 143 | -11x | +
| 1 | +
- } else if (x_stats[["range"]][1] == rng_censor_lwr) {
+ #' Patient Counts with the Most Extreme Post-baseline Toxicity Grade per Direction of Abnormality |
|||
| 144 | -2x | +|||
| 2 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum"+ #' |
|||
| 145 | -9x | +|||
| 3 | +
- } else if (x_stats[["range"]][2] == rng_censor_upr) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 146 | -1x | +|||
| 4 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum"+ #' |
|||
| 147 | +5 |
- }+ #' Primary analysis variable `.var` indicates the toxicity grade (`factor`), and additional |
||
| 148 | +6 |
- }+ #' analysis variables are `id` (`character` or `factor`), `param` (`factor`) and `grade_dir` (`factor`). |
||
| 149 | +7 |
-
+ #' The pre-processing steps are crucial when using this function. |
||
| 150 | -12x | +|||
| 8 | +
- in_rows(+ #' For a certain direction (e.g. high or low) this function counts |
|||
| 151 | -12x | +|||
| 9 | +
- .list = x_stats,+ #' patients in the denominator as number of patients with at least one valid measurement during treatment, |
|||
| 152 | -12x | +|||
| 10 | +
- .formats = .formats,+ #' and patients in the numerator as follows: |
|||
| 153 | -12x | +|||
| 11 | +
- .names = .labels,+ #' * `1` to `4`: Numerator is number of patients with worst grades 1-4 respectively; |
|||
| 154 | -12x | +|||
| 12 | +
- .labels = .labels,+ #' * `Any`: Numerator is number of patients with at least one abnormality, which means grade is different from 0. |
|||
| 155 | -12x | +|||
| 13 | +
- .indent_mods = .indent_mods,+ #' |
|||
| 156 | -12x | +|||
| 14 | +
- .format_na_strs = na_str,+ #' Pre-processing is crucial when using this function and can be done automatically using the |
|||
| 157 | -12x | +|||
| 15 | +
- .cell_footnotes = cell_fns+ #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the |
|||
| 158 | +16 |
- )+ #' necessary pre-processing steps. |
||
| 159 | +17 |
- }+ #' |
||
| 160 | +18 |
-
+ #' @inheritParams argument_convention |
||
| 161 | +19 |
- #' @describeIn survival_time Layout-creating function which can take statistics function arguments+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade")`
|
||
| 162 | +20 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' to see available statistics for this function. |
||
| 163 | +21 |
#' |
||
| 164 | +22 |
- #' @return+ #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes `ADLB` data frames to be used in |
||
| 165 | +23 |
- #' * `surv_time()` returns a layout object suitable for passing to further layouting functions,+ #' [count_abnormal_by_worst_grade()]. |
||
| 166 | +24 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 167 | +25 |
- #' the statistics from `s_surv_time()` to the table layout.+ #' @name abnormal_by_worst_grade |
||
| 168 | +26 |
- #'+ #' @order 1 |
||
| 169 | +27 |
- #' @examples+ NULL |
||
| 170 | +28 |
- #' basic_table() %>%+ |
||
| 171 | +29 |
- #' split_cols_by(var = "ARMCD") %>%+ #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade. |
||
| 172 | +30 |
- #' add_colcounts() %>%+ #' |
||
| 173 | +31 |
- #' surv_time(+ #' @return |
||
| 174 | +32 |
- #' vars = "AVAL",+ #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and |
||
| 175 | +33 |
- #' var_labels = "Survival Time (Months)",+ #' "Any" results. |
||
| 176 | +34 |
- #' is_event = "is_event",+ #' |
||
| 177 | +35 |
- #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log")+ #' @keywords internal |
||
| 178 | +36 |
- #' ) %>%+ s_count_abnormal_by_worst_grade <- function(df, # nolint |
||
| 179 | +37 |
- #' build_table(df = adtte_f)+ .var = "GRADE_ANL", |
||
| 180 | +38 |
- #'+ .spl_context, |
||
| 181 | +39 |
- #' @export+ variables = list( |
||
| 182 | +40 |
- #' @order 2+ id = "USUBJID", |
||
| 183 | +41 |
- surv_time <- function(lyt,+ param = "PARAM", |
||
| 184 | +42 |
- vars,+ grade_dir = "GRADE_DIR" |
||
| 185 | +43 |
- is_event,+ )) {
|
||
| 186 | -+ | |||
| 44 | +1x |
- control = control_surv_time(),+ checkmate::assert_string(.var) |
||
| 187 | -+ | |||
| 45 | +1x |
- ref_fn_censor = TRUE,+ assert_valid_factor(df[[.var]]) |
||
| 188 | -+ | |||
| 46 | +1x |
- na_str = default_na_str(),+ assert_valid_factor(df[[variables$param]]) |
||
| 189 | -+ | |||
| 47 | +1x |
- nested = TRUE,+ assert_valid_factor(df[[variables$grade_dir]]) |
||
| 190 | -+ | |||
| 48 | +1x |
- ...,+ assert_df_with_variables(df, c(a = .var, variables)) |
||
| 191 | -+ | |||
| 49 | +1x |
- var_labels = "Time to Event",+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
||
| 192 | +50 |
- show_labels = "visible",+ |
||
| 193 | +51 |
- table_names = vars,+ # To verify that the `split_rows_by` are performed with correct variables. |
||
| 194 | -+ | |||
| 52 | +1x |
- .stats = c("median", "median_ci", "quantiles", "range"),
+ checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split) |
||
| 195 | -+ | |||
| 53 | +1x |
- .formats = NULL,+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
||
| 196 | -+ | |||
| 54 | +1x |
- .labels = NULL,+ x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ |
+ ||
| 55 | +1x | +
+ result <- split(numeric(0), factor(x_lvls)) |
||
| 197 | +56 |
- .indent_mods = c(median_ci = 1L)) {
+
|
||
| 198 | -3x | +57 | +1x |
- extra_args <- list(+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
| 199 | -3x | +58 | +1x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str,+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
| 200 | -3x | +|||
| 59 | +
- is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ...+ # Some subjects may have a record for high and low directions but |
|||
| 201 | +60 |
- )+ # should be counted only once.+ |
+ ||
| 61 | +1x | +
+ denom <- length(unique(subj_cur_col)) |
||
| 202 | +62 | |||
| 203 | -3x | +63 | +1x |
- analyze(+ for (lvl in x_lvls) {
|
| 204 | -3x | +64 | +5x |
- lyt = lyt,+ if (lvl != "Any") {
|
| 205 | -3x | +65 | +4x |
- vars = vars,+ df_lvl <- df[df[[.var]] == lvl, ] |
| 206 | -3x | +|||
| 66 | +
- afun = a_surv_time,+ } else {
|
|||
| 207 | -3x | +67 | +1x |
- var_labels = var_labels,+ df_lvl <- df[df[[.var]] != 0, ] |
| 208 | -3x | +|||
| 68 | +
- show_labels = show_labels,+ } |
|||
| 209 | -3x | +69 | +5x |
- table_names = table_names,+ num <- length(unique(df_lvl[[variables[["id"]]]])) |
| 210 | -3x | +70 | +5x |
- na_str = na_str,+ fraction <- ifelse(denom == 0, 0, num / denom) |
| 211 | -3x | +71 | +5x |
- nested = nested,+ result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl) |
| 212 | -3x | +|||
| 72 | +
- extra_args = extra_args+ } |
|||
| 213 | +73 |
- )+ + |
+ ||
| 74 | +1x | +
+ result <- list(count_fraction = result)+ |
+ ||
| 75 | +1x | +
+ result |
||
| 214 | +76 |
} |
| 1 | +77 |
- #' Sort Data by `PK PARAM` Variable+ |
|
| 2 | +78 |
- #'+ #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun` |
|
| 3 | +79 |
- #' @description `r lifecycle::badge("stable")`
+ #' in `count_abnormal_by_worst_grade()`. |
|
| 4 | +80 |
#' |
|
| 5 | +81 |
- #' @param pk_data (`data.frame`)\cr `Pharmacokinetics` dataframe+ #' @return |
|
| 6 | +82 |
- #' @param key_var (`character`)\cr key variable used to merge pk_data and metadata created by `d_pkparam()`+ #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 7 | +83 |
#' |
|
| 8 | +84 |
- #' @return A PK `data.frame` sorted by a `PARAM` variable.+ #' @keywords internal |
|
| 9 | +85 |
- #'+ a_count_abnormal_by_worst_grade <- make_afun( # nolint |
|
| 10 | +86 |
- #' @examples+ s_count_abnormal_by_worst_grade, |
|
| 11 | +87 |
- #' library(dplyr)+ .formats = c(count_fraction = format_count_fraction) |
|
| 12 | +88 |
- #'+ ) |
|
| 13 | +89 |
- #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
+
|
|
| 14 | +90 |
- #' pk_ordered_data <- h_pkparam_sort(adpp)+ #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments |
|
| 15 | +91 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 16 | +92 |
- #' @export+ #' |
|
| 17 | +93 |
- h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
- |
- |
| 18 | -4x | -
- assert_df_with_variables(pk_data, list(key_var = key_var))+ #' @return |
|
| 19 | -4x | +||
| 94 | +
- pk_data$PARAMCD <- pk_data[[key_var]]+ #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 20 | +95 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 21 | -4x | +||
| 96 | +
- ordered_pk_data <- d_pkparam()+ #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout. |
||
| 22 | +97 |
-
+ #' |
|
| 23 | +98 |
- # Add the numeric values from ordered_pk_data to pk_data+ #' @examples |
|
| 24 | -4x | +||
| 99 | +
- joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffix = c("", ".y"))
+ #' library(dplyr) |
||
| 25 | +100 |
-
+ #' library(forcats) |
|
| 26 | -4x | +||
| 101 | +
- joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
+ #' adlb <- tern_ex_adlb |
||
| 27 | +102 |
-
+ #' |
|
| 28 | -4x | +||
| 103 | +
- joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER)+ #' # Data is modified in order to have some parameters with grades only in one direction |
||
| 29 | +104 |
-
+ #' # and simulate the real data. |
|
| 30 | +105 |
- # Then order PARAM based on this column+ #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
|
|
| 31 | -4x | +||
| 106 | +
- joined_data$PARAM <- factor(joined_data$PARAM,+ #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW" |
||
| 32 | -4x | +||
| 107 | +
- levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- "" |
||
| 33 | -4x | +||
| 108 | +
- ordered = TRUE+ #' |
||
| 34 | +109 |
- )+ #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
|
|
| 35 | +110 |
-
+ #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH" |
|
| 36 | -4x | +||
| 111 | +
- joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY,+ #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- "" |
||
| 37 | -4x | +||
| 112 | +
- levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),+ #' |
||
| 38 | -4x | +||
| 113 | +
- ordered = TRUE+ #' # Pre-processing |
||
| 39 | +114 |
- )+ #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade() |
|
| 40 | +115 |
-
+ #' |
|
| 41 | -4x | +||
| 116 | +
- joined_data+ #' # Map excludes records without abnormal grade since they should not be displayed |
||
| 42 | +117 |
- }+ #' # in the table. |
| 1 | +118 |
- #' Formatting Functions+ #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
|
||
| 2 | +119 |
- #'+ #' lapply(as.character) %>% |
||
| 3 | +120 |
- #' @description `r lifecycle::badge("stable")`
+ #' as.data.frame() %>% |
||
| 4 | +121 |
- #'+ #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL) |
||
| 5 | +122 |
- #' See below for the list of formatting functions created in `tern` to work with `rtables`.+ #' |
||
| 6 | +123 |
- #'+ #' basic_table() %>% |
||
| 7 | +124 |
- #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional+ #' split_cols_by("ARMCD") %>%
|
||
| 8 | +125 |
- #' custom formats can be created via the [`formatters::sprintf_format()`] function.+ #' split_rows_by("PARAM") %>%
|
||
| 9 | +126 |
- #'+ #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
|
||
| 10 | +127 |
- #' @family formatting functions+ #' count_abnormal_by_worst_grade( |
||
| 11 | +128 |
- #' @name formatting_functions+ #' var = "GRADE_ANL", |
||
| 12 | +129 |
- NULL+ #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR") |
||
| 13 | +130 |
-
+ #' ) %>% |
||
| 14 | +131 |
- #' Formatting Fraction and Percentage+ #' build_table(df = adlb_f) |
||
| 15 | +132 |
#' |
||
| 16 | +133 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 17 | +134 |
- #'+ #' @order 2 |
||
| 18 | +135 |
- #' Formats a fraction together with ratio in percent.+ count_abnormal_by_worst_grade <- function(lyt, |
||
| 19 | +136 |
- #'+ var, |
||
| 20 | +137 |
- #' @param x (`integer`)\cr with elements `num` and `denom`.+ variables = list( |
||
| 21 | +138 |
- #' @param ... required for `rtables` interface.+ id = "USUBJID", |
||
| 22 | +139 |
- #'+ param = "PARAM", |
||
| 23 | +140 |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ grade_dir = "GRADE_DIR" |
||
| 24 | +141 |
- #'+ ), |
||
| 25 | +142 |
- #' @examples+ na_str = default_na_str(), |
||
| 26 | +143 |
- #' format_fraction(x = c(num = 2L, denom = 3L))+ nested = TRUE, |
||
| 27 | +144 |
- #' format_fraction(x = c(num = 0L, denom = 3L))+ ..., |
||
| 28 | +145 |
- #'+ .stats = NULL, |
||
| 29 | +146 |
- #' @family formatting functions+ .formats = NULL, |
||
| 30 | +147 |
- #' @export+ .labels = NULL, |
||
| 31 | +148 |
- format_fraction <- function(x, ...) {
+ .indent_mods = NULL) {
|
||
| 32 | -4x | +149 | +2x |
- attr(x, "label") <- NULL+ extra_args <- list(variables = variables, ...) |
| 33 | +150 | |||
| 34 | -4x | +151 | +2x |
- checkmate::assert_vector(x)+ afun <- make_afun( |
| 35 | -4x | +152 | +2x |
- checkmate::assert_count(x["num"])+ a_count_abnormal_by_worst_grade, |
| 36 | +153 | 2x |
- checkmate::assert_count(x["denom"])+ .stats = .stats, |
|
| 37 | -+ | |||
| 154 | +2x |
-
+ .formats = .formats, |
||
| 38 | +155 | 2x |
- result <- if (x["num"] == 0) {
+ .labels = .labels, |
|
| 39 | -1x | +156 | +2x |
- paste0(x["num"], "/", x["denom"])+ .indent_mods = .indent_mods,+ |
+
| 157 | +2x | +
+ .ungroup_stats = "count_fraction" |
||
| 40 | +158 |
- } else {
+ ) |
||
| 41 | -1x | +159 | +2x |
- paste0(+ analyze( |
| 42 | -1x | +160 | +2x |
- x["num"], "/", x["denom"],+ lyt = lyt, |
| 43 | -1x | +161 | +2x |
- " (", round(x["num"] / x["denom"] * 100, 1), "%)"
+ vars = var, |
| 44 | -+ | |||
| 162 | +2x |
- )+ afun = afun, |
||
| 45 | -+ | |||
| 163 | +2x |
- }+ na_str = na_str, |
||
| 46 | -+ | |||
| 164 | +2x |
-
+ nested = nested, |
||
| 47 | +165 | 2x |
- return(result)+ extra_args = extra_args,+ |
+ |
| 166 | +2x | +
+ show_labels = "hidden" |
||
| 48 | +167 | ++ |
+ )+ |
+ |
| 168 |
} |
|||
| 49 | +169 | |||
| 50 | +170 |
- #' Formatting Fraction and Percentage with Fixed Single Decimal Place+ #' Helper function to prepare `ADLB` for [count_abnormal_by_worst_grade()] |
||
| 51 | +171 |
#' |
||
| 52 | +172 |
#' @description `r lifecycle::badge("stable")`
|
||
| 53 | +173 |
#' |
||
| 54 | +174 |
- #' Formats a fraction together with ratio in percent with fixed single decimal place.+ #' Helper function to prepare an `ADLB` data frame to be used as input in |
||
| 55 | +175 |
- #' Includes trailing zero in case of whole number percentages to always keep one decimal place.+ #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied: |
||
| 56 | +176 |
#' |
||
| 57 | +177 |
- #' @param x (`integer`)\cr with elements `num` and `denom`.+ #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits. |
||
| 58 | +178 |
- #' @param ... required for `rtables` interface.+ #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only |
||
| 59 | +179 |
- #'+ #' worst grades (in either direction) are included. |
||
| 60 | +180 |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived |
||
| 61 | +181 |
- #'+ #' and added to `adlb`: |
||
| 62 | +182 |
- #' @examples+ #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when |
||
| 63 | +183 |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L))+ #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise. |
||
| 64 | +184 |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L))+ #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are |
||
| 65 | +185 |
- #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L))+ #' replaced by their absolute values. |
||
| 66 | +186 |
- #'+ #' 4. Unused factor levels are dropped from `adlb` via [droplevels()]. |
||
| 67 | +187 |
- #' @family formatting functions+ #' |
||
| 68 | +188 |
- #' @export+ #' @param adlb (`data.frame`)\cr `ADLB` dataframe. |
||
| 69 | +189 |
- format_fraction_fixed_dp <- function(x, ...) {
- |
- ||
| 70 | -3x | -
- attr(x, "label") <- NULL+ #' @param atoxgr (`character`)\cr Analysis toxicity grade variable. This must be a `factor` |
||
| 71 | -3x | +|||
| 190 | +
- checkmate::assert_vector(x)+ #' variable. |
|||
| 72 | -3x | +|||
| 191 | +
- checkmate::assert_count(x["num"])+ #' @param avisit (`character`)\cr Analysis visit variable. |
|||
| 73 | -3x | +|||
| 192 | +
- checkmate::assert_count(x["denom"])+ #' @param worst_flag_low (`character`)\cr Worst low lab grade flag variable. This variable is |
|||
| 74 | +193 |
-
+ #' set to `"Y"` when indicating records of worst low lab grades. |
||
| 75 | -3x | +|||
| 194 | +
- result <- if (x["num"] == 0) {
+ #' @param worst_flag_high (`character`)\cr Worst high lab grade flag variable. This variable is |
|||
| 76 | -1x | +|||
| 195 | +
- paste0(x["num"], "/", x["denom"])+ #' set to `"Y"` when indicating records of worst high lab grades. |
|||
| 77 | +196 |
- } else {
+ #' |
||
| 78 | -2x | +|||
| 197 | +
- paste0(+ #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new |
|||
| 79 | -2x | +|||
| 198 | +
- x["num"], "/", x["denom"],+ #' variables: `GRADE_DIR` and `GRADE_ANL`. |
|||
| 80 | -2x | +|||
| 199 | +
- " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
+ #' |
|||
| 81 | +200 |
- )+ #' @seealso [abnormal_by_worst_grade] |
||
| 82 | +201 |
- }+ #' |
||
| 83 | -3x | +|||
| 202 | +
- return(result)+ #' @examples |
|||
| 84 | +203 |
- }+ #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>% |
||
| 85 | +204 |
-
+ #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>% |
||
| 86 | +205 |
- #' Formatting Count and Fraction+ #' head(10) |
||
| 87 | +206 |
#' |
||
| 88 | +207 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 89 | +208 |
- #'+ h_adlb_abnormal_by_worst_grade <- function(adlb, |
||
| 90 | +209 |
- #' Formats a count together with fraction with special consideration when count is `0`.+ atoxgr = "ATOXGR", |
||
| 91 | +210 |
- #'+ avisit = "AVISIT", |
||
| 92 | +211 |
- #' @param x (`integer`)\cr vector of length 2, count and fraction.+ worst_flag_low = "WGRLOFL", |
||
| 93 | +212 |
- #' @param ... required for `rtables` interface.+ worst_flag_high = "WGRHIFL") {
|
||
| 94 | -+ | |||
| 213 | +1x |
- #'+ adlb %>% |
||
| 95 | -+ | |||
| 214 | +1x |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ dplyr::filter( |
||
| 96 | -+ | |||
| 215 | +1x |
- #'+ !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
|
||
| 97 | -+ | |||
| 216 | +1x |
- #' @examples+ .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y" |
||
| 98 | +217 |
- #' format_count_fraction(x = c(2, 0.6667))+ ) %>% |
||
| 99 | -+ | |||
| 218 | +1x |
- #' format_count_fraction(x = c(0, 0))+ dplyr::mutate(+ |
+ ||
| 219 | +1x | +
+ GRADE_DIR = factor(+ |
+ ||
| 220 | +1x | +
+ dplyr::case_when(+ |
+ ||
| 221 | +1x | +
+ .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ |
+ ||
| 222 | +1x | +
+ .data[[atoxgr]] == "0" ~ "ZERO",+ |
+ ||
| 223 | +1x | +
+ .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
|
||
| 100 | +224 |
- #'+ ),+ |
+ ||
| 225 | +1x | +
+ levels = c("LOW", "ZERO", "HIGH")
|
||
| 101 | +226 |
- #' @family formatting functions+ ),+ |
+ ||
| 227 | +1x | +
+ GRADE_ANL = forcats::fct_relevel(+ |
+ ||
| 228 | +1x | +
+ forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ |
+ ||
| 229 | +1x | +
+ c("0", "1", "2", "3", "4")
|
||
| 102 | +230 |
- #' @export+ ) |
||
| 103 | +231 |
- format_count_fraction <- function(x, ...) {
+ ) %>% |
||
| 104 | -3x | +232 | +1x |
- attr(x, "label") <- NULL+ droplevels() |
| 105 | +233 |
-
+ } |
||
| 106 | -3x | +
| 1 | +
- if (any(is.na(x))) {
+ #' Tabulate Biomarker Effects on Binary Response by Subgroup |
|||
| 107 | -1x | +|||
| 2 | +
- return("NA")
+ #' |
|||
| 108 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 109 | +4 |
-
+ #' |
||
| 110 | -2x | +|||
| 5 | +
- checkmate::assert_vector(x)+ #' Tabulate the estimated effects of multiple continuous biomarker variables |
|||
| 111 | -2x | +|||
| 6 | +
- checkmate::assert_integerish(x[1])+ #' on a binary response endpoint across population subgroups. |
|||
| 112 | -2x | +|||
| 7 | +
- assert_proportion_value(x[2], include_boundaries = TRUE)+ #' |
|||
| 113 | +8 |
-
+ #' @inheritParams argument_convention |
||
| 114 | -2x | +|||
| 9 | +
- result <- if (x[1] == 0) {
+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
|||
| 115 | -1x | +|||
| 10 | +
- "0"+ #' [extract_rsp_biomarkers()]. |
|||
| 116 | +11 |
- } else {
+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 117 | -1x | +|||
| 12 | +
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ #' * `n_tot`: Total number of patients per group. |
|||
| 118 | +13 |
- }+ #' * `n_rsp`: Total number of responses per group. |
||
| 119 | +14 |
-
+ #' * `prop`: Total response proportion per group. |
||
| 120 | -2x | +|||
| 15 | +
- return(result)+ #' * `or`: Odds ratio. |
|||
| 121 | +16 |
- }+ #' * `ci`: Confidence interval of odds ratio. |
||
| 122 | +17 |
-
+ #' * `pval`: p-value of the effect. |
||
| 123 | +18 |
- #' Formatting Count and Percentage with Fixed Single Decimal Place+ #' Note, the statistics `n_tot`, `or` and `ci` are required. |
||
| 124 | +19 |
#' |
||
| 125 | +20 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup. |
||
| 126 | +21 |
#' |
||
| 127 | +22 |
- #' Formats a count together with fraction with special consideration when count is `0`.+ #' @details These functions create a layout starting from a data frame which contains |
||
| 128 | +23 |
- #'+ #' the required statistics. The tables are then typically used as input for forest plots. |
||
| 129 | +24 |
- #' @param x (`integer`)\cr vector of length 2, count and fraction.+ #' |
||
| 130 | +25 |
- #' @param ... required for `rtables` interface.+ #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does |
||
| 131 | +26 |
- #'+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 132 | +27 |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ #' created by combining multiple subtables. |
||
| 133 | +28 |
#' |
||
| 134 | +29 |
- #' @examples+ #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()]. |
||
| 135 | +30 |
- #' format_count_fraction_fixed_dp(x = c(2, 0.6667))+ #' |
||
| 136 | +31 |
- #' format_count_fraction_fixed_dp(x = c(2, 0.5))+ #' @examples |
||
| 137 | +32 |
- #' format_count_fraction_fixed_dp(x = c(0, 0))+ #' library(dplyr) |
||
| 138 | +33 | ++ |
+ #' library(forcats)+ |
+ |
| 34 |
#' |
|||
| 139 | +35 |
- #' @family formatting functions+ #' adrs <- tern_ex_adrs |
||
| 140 | +36 |
- #' @export+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 141 | +37 |
- format_count_fraction_fixed_dp <- function(x, ...) {
+ #' |
||
| 142 | -3x | +|||
| 38 | +
- attr(x, "label") <- NULL+ #' adrs_f <- adrs %>% |
|||
| 143 | +39 |
-
+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 144 | -3x | +|||
| 40 | +
- if (any(is.na(x))) {
+ #' mutate(rsp = AVALC == "CR") |
|||
| 145 | -! | +|||
| 41 | +
- return("NA")
+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
|||
| 146 | +42 |
- }+ #' |
||
| 147 | +43 |
-
+ #' df <- extract_rsp_biomarkers( |
||
| 148 | -3x | +|||
| 44 | +
- checkmate::assert_vector(x)+ #' variables = list( |
|||
| 149 | -3x | +|||
| 45 | +
- checkmate::assert_integerish(x[1])+ #' rsp = "rsp", |
|||
| 150 | -3x | +|||
| 46 | +
- assert_proportion_value(x[2], include_boundaries = TRUE)+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 151 | +47 |
-
+ #' covariates = "SEX", |
||
| 152 | -3x | +|||
| 48 | +
- result <- if (x[1] == 0) {
+ #' subgroups = "BMRKR2" |
|||
| 153 | -1x | +|||
| 49 | +
- "0"+ #' ), |
|||
| 154 | -3x | +|||
| 50 | +
- } else if (x[2] == 1) {
+ #' data = adrs_f |
|||
| 155 | -! | +|||
| 51 | +
- sprintf("%d (100%%)", x[1])
+ #' ) |
|||
| 156 | +52 |
- } else {
+ #' |
||
| 157 | -2x | +|||
| 53 | +
- sprintf("%d (%.1f%%)", x[1], x[2] * 100)
+ #' \donttest{
|
|||
| 158 | +54 |
- }+ #' ## Table with default columns. |
||
| 159 | +55 |
-
+ #' tabulate_rsp_biomarkers(df) |
||
| 160 | -3x | +|||
| 56 | +
- return(result)+ #' |
|||
| 161 | +57 |
- }+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
||
| 162 | +58 |
-
+ #' tab <- tabulate_rsp_biomarkers( |
||
| 163 | +59 |
- #' Formatting Count and Fraction with Special Case for Count < 10+ #' df = df, |
||
| 164 | +60 |
- #'+ #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
|
||
| 165 | +61 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 166 | +62 |
#' |
||
| 167 | +63 |
- #' Formats a count together with fraction with special consideration when count is less than 10.+ #' ## Finally produce the forest plot. |
||
| 168 | +64 |
- #'+ #' g_forest(tab, xlim = c(0.7, 1.4)) |
||
| 169 | +65 |
- #' @inheritParams format_count_fraction+ #' } |
||
| 170 | +66 |
#' |
||
| 171 | +67 |
- #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed.+ #' @export |
||
| 172 | +68 |
- #'+ #' @name response_biomarkers_subgroups |
||
| 173 | +69 |
- #' @examples+ tabulate_rsp_biomarkers <- function(df, |
||
| 174 | +70 |
- #' format_count_fraction_lt10(x = c(275, 0.9673))+ vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
||
| 175 | +71 |
- #' format_count_fraction_lt10(x = c(2, 0.6667))+ na_str = default_na_str(),+ |
+ ||
| 72 | ++ |
+ .indent_mods = 0L) {
+ |
+ ||
| 73 | +4x | +
+ checkmate::assert_data_frame(df)+ |
+ ||
| 74 | +4x | +
+ checkmate::assert_character(df$biomarker)+ |
+ ||
| 75 | +4x | +
+ checkmate::assert_character(df$biomarker_label) |
||
| 176 | -+ | |||
| 76 | +4x |
- #' format_count_fraction_lt10(x = c(9, 1))+ checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
|
||
| 177 | +77 |
- #'+ |
||
| 178 | -+ | |||
| 78 | +4x |
- #' @family formatting functions+ df_subs <- split(df, f = df$biomarker) |
||
| 179 | -+ | |||
| 79 | +4x |
- #' @export+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
||
| 180 | -+ | |||
| 80 | +7x |
- format_count_fraction_lt10 <- function(x, ...) {
+ tab_sub <- h_tab_rsp_one_biomarker( |
||
| 181 | +81 | 7x |
- attr(x, "label") <- NULL+ df = df_sub, |
|
| 182 | -+ | |||
| 82 | +7x |
-
+ vars = vars, |
||
| 183 | +83 | 7x |
- if (any(is.na(x))) {
+ na_str = na_str, |
|
| 184 | -1x | +84 | +7x |
- return("NA")
+ .indent_mods = .indent_mods |
| 185 | +85 |
- }+ ) |
||
| 186 | +86 |
-
+ # Insert label row as first row in table. |
||
| 187 | -6x | +87 | +7x |
- checkmate::assert_vector(x)+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
| 188 | -6x | +88 | +7x |
- checkmate::assert_integerish(x[1])+ tab_sub+ |
+
| 89 | ++ |
+ }) |
||
| 189 | -6x | +90 | +4x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ result <- do.call(rbind, tabs) |
| 190 | +91 | |||
| 191 | -6x | +92 | +4x |
- result <- if (x[1] < 10) {
+ n_id <- grep("n_tot", vars)
|
| 192 | -3x | +93 | +4x |
- paste0(x[1])+ or_id <- match("or", vars)
|
| 193 | -+ | |||
| 94 | +4x |
- } else {
+ ci_id <- match("ci", vars)
|
||
| 194 | -3x | +95 | +4x |
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ structure( |
| 195 | -+ | |||
| 96 | +4x |
- }+ result, |
||
| 196 | -+ | |||
| 97 | +4x |
-
+ forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
|
||
| 197 | -6x | +98 | +4x |
- return(result)+ col_x = or_id, |
| 198 | -+ | |||
| 99 | +4x |
- }+ col_ci = ci_id, |
||
| 199 | -+ | |||
| 100 | +4x |
-
+ col_symbol_size = n_id |
||
| 200 | +101 |
- #' Formatting: XX as Formatting Function+ ) |
||
| 201 | +102 |
- #'+ } |
||
| 202 | +103 |
- #' Translate a string where x and dots are interpreted as number place+ |
||
| 203 | +104 |
- #' holders, and others as formatting elements.+ #' Prepares Response Data Estimates for Multiple Biomarkers in a Single Data Frame |
||
| 204 | +105 |
#' |
||
| 205 | +106 |
- #' @param str (`string`)\cr template.+ #' @description `r lifecycle::badge("stable")`
|
||
| 206 | +107 |
#' |
||
| 207 | +108 |
- #' @return An `rtables` formatting function.+ #' Prepares estimates for number of responses, patients and overall response rate, |
||
| 208 | +109 |
- #'+ #' as well as odds ratio estimates, confidence intervals and p-values, |
||
| 209 | +110 |
- #' @examples+ #' for multiple biomarkers across population subgroups in a single data frame. |
||
| 210 | +111 |
- #' test <- list(c(1.658, 0.5761), c(1e1, 785.6))+ #' `variables` corresponds to the names of variables found in `data`, passed as a |
||
| 211 | +112 |
- #'+ #' named list and requires elements `rsp` and `biomarkers` (vector of continuous |
||
| 212 | +113 |
- #' z <- format_xx("xx (xx.x)")
+ #' biomarker variables) and optionally `covariates`, `subgroups` and `strata`. |
||
| 213 | +114 |
- #' sapply(test, z)+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 214 | +115 |
#' |
||
| 215 | +116 |
- #' z <- format_xx("xx.x - xx.x")
+ #' @inheritParams argument_convention |
||
| 216 | +117 |
- #' sapply(test, z)+ #' @inheritParams response_subgroups |
||
| 217 | +118 |
- #'+ #' @param control (named `list`)\cr controls for the response definition and the |
||
| 218 | +119 |
- #' z <- format_xx("xx.x, incl. xx.x% NE")
+ #' confidence level produced by [control_logistic()]. |
||
| 219 | +120 |
- #' sapply(test, z)+ #' |
||
| 220 | +121 |
- #'+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`, |
||
| 221 | +122 |
- #' @family formatting functions+ #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
||
| 222 | +123 |
- #' @export+ #' `var_label`, and `row_type`. |
||
| 223 | +124 |
- format_xx <- function(str) {
+ #' |
||
| 224 | +125 |
- # Find position in the string.- |
- ||
| 225 | -1x | -
- positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE)- |
- ||
| 226 | -1x | -
- x_positions <- regmatches(x = str, m = positions)[[1]]+ #' @note You can also specify a continuous variable in `rsp` and then use the |
||
| 227 | +126 |
-
+ #' `response_definition` control to convert that internally to a logical |
||
| 228 | +127 |
- # Roundings depends on the number of x behind [.].- |
- ||
| 229 | -1x | -
- roundings <- lapply(- |
- ||
| 230 | -1x | -
- X = x_positions,- |
- ||
| 231 | -1x | -
- function(x) {
- |
- ||
| 232 | -2x | -
- y <- strsplit(split = "\\.", x = x)[[1]]- |
- ||
| 233 | -2x | -
- rounding <- function(x) {
- |
- ||
| 234 | -4x | -
- round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0))+ #' variable reflecting binary response. |
||
| 235 | +128 |
- }- |
- ||
| 236 | -2x | -
- return(rounding)+ #' |
||
| 237 | +129 |
- }+ #' @seealso [h_logistic_mult_cont_df()] which is used internally. |
||
| 238 | +130 |
- )+ #' |
||
| 239 | +131 |
-
+ #' @examples |
||
| 240 | -1x | +|||
| 132 | +
- rtable_format <- function(x, output) {
+ #' library(dplyr) |
|||
| 241 | -2x | +|||
| 133 | +
- values <- Map(y = x, fun = roundings, function(y, fun) fun(y))+ #' library(forcats) |
|||
| 242 | -2x | +|||
| 134 | +
- regmatches(x = str, m = positions)[[1]] <- values+ #' |
|||
| 243 | -2x | +|||
| 135 | +
- return(str)+ #' adrs <- tern_ex_adrs |
|||
| 244 | +136 |
- }+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 245 | +137 |
-
+ #' |
||
| 246 | -1x | +|||
| 138 | +
- return(rtable_format)+ #' adrs_f <- adrs %>% |
|||
| 247 | +139 |
- }+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 248 | +140 |
-
+ #' mutate(rsp = AVALC == "CR") |
||
| 249 | +141 |
- #' Formatting Numeric Values By Significant Figures+ #' |
||
| 250 | +142 |
- #'+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
||
| 251 | +143 |
- #' Format numeric values to print with a specified number of significant figures.+ #' # in logistic regression models with one covariate `RACE`. The subgroups |
||
| 252 | +144 |
- #'+ #' # are defined by the levels of `BMRKR2`. |
||
| 253 | +145 |
- #' @param sigfig (`integer`)\cr number of significant figures to display.+ #' df <- extract_rsp_biomarkers( |
||
| 254 | +146 |
- #' @param format (`character`)\cr the format label (string) to apply when printing the value. Decimal+ #' variables = list( |
||
| 255 | +147 |
- #' places in string are ignored in favor of formatting by significant figures. Formats options are:+ #' rsp = "rsp", |
||
| 256 | +148 |
- #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`.+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 257 | +149 |
- #' @param num_fmt (`character`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for+ #' covariates = "SEX", |
||
| 258 | +150 |
- #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`)+ #' subgroups = "BMRKR2" |
||
| 259 | +151 |
- #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the+ #' ), |
||
| 260 | +152 |
- #' [formatC()] `format` argument for more options.+ #' data = adrs_f |
||
| 261 | +153 |
- #'+ #' ) |
||
| 262 | +154 |
- #' @return An `rtables` formatting function.+ #' df |
||
| 263 | +155 |
#' |
||
| 264 | +156 |
- #' @examples+ #' # Here we group the levels of `BMRKR2` manually, and we add a stratification |
||
| 265 | +157 |
- #' fmt_3sf <- format_sigfig(3)+ #' # variable `STRATA1`. We also here use a continuous variable `EOSDY` |
||
| 266 | +158 |
- #' fmt_3sf(1.658)+ #' # which is then binarized internally (response is defined as this variable |
||
| 267 | +159 |
- #' fmt_3sf(1e1)+ #' # being larger than 750). |
||
| 268 | +160 |
- #'+ #' df_grouped <- extract_rsp_biomarkers( |
||
| 269 | +161 |
- #' fmt_5sf <- format_sigfig(5)+ #' variables = list( |
||
| 270 | +162 |
- #' fmt_5sf(0.57)+ #' rsp = "EOSDY", |
||
| 271 | +163 |
- #' fmt_5sf(0.000025645)+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 272 | +164 |
- #'+ #' covariates = "SEX", |
||
| 273 | +165 |
- #' @family formatting functions+ #' subgroups = "BMRKR2", |
||
| 274 | +166 |
- #' @export+ #' strata = "STRATA1" |
||
| 275 | +167 |
- format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
+ #' ), |
||
| 276 | -2x | +|||
| 168 | +
- checkmate::assert_integerish(sigfig)+ #' data = adrs_f, |
|||
| 277 | -2x | +|||
| 169 | +
- format <- gsub("xx\\.|xx\\.x+", "xx", format)
+ #' groups_lists = list( |
|||
| 278 | -2x | +|||
| 170 | +
- checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
+ #' BMRKR2 = list( |
|||
| 279 | -2x | +|||
| 171 | +
- function(x, ...) {
+ #' "low" = "LOW", |
|||
| 280 | -! | +|||
| 172 | +
- if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 281 | -9x | +|||
| 173 | +
- num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#")+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|||
| 282 | -9x | +|||
| 174 | +
- num <- gsub("\\.$", "", num) # remove trailing "."
+ #' ) |
|||
| 283 | +175 |
-
+ #' ), |
||
| 284 | -9x | +|||
| 176 | +
- format_value(num, format)+ #' control = control_logistic( |
|||
| 285 | +177 |
- }+ #' response_definition = "I(response > 750)" |
||
| 286 | +178 |
- }+ #' ) |
||
| 287 | +179 |
-
+ #' ) |
||
| 288 | +180 |
- #' Formatting Fraction with Lower Threshold+ #' df_grouped |
||
| 289 | +181 |
#' |
||
| 290 | +182 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 291 | +183 |
- #'+ extract_rsp_biomarkers <- function(variables, |
||
| 292 | +184 |
- #' Formats a fraction when the second element of the input `x` is the fraction. It applies+ data, |
||
| 293 | +185 |
- #' a lower threshold, below which it is just stated that the fraction is smaller than that.+ groups_lists = list(), |
||
| 294 | +186 |
- #'+ control = control_logistic(), |
||
| 295 | +187 |
- #' @param threshold (`proportion`)\cr lower threshold.+ label_all = "All Patients") {
|
||
| 296 | -+ | |||
| 188 | +5x |
- #'+ if ("strat" %in% names(variables)) {
|
||
| 297 | -+ | |||
| 189 | +! |
- #' @return An `rtables` formatting function that takes numeric input `x` where the second+ warning( |
||
| 298 | -+ | |||
| 190 | +! |
- #' element is the fraction that is formatted. If the fraction is above or equal to the threshold,+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_biomarkers() ", |
||
| 299 | -+ | |||
| 191 | +! |
- #' then it is displayed in percentage. If it is positive but below the threshold, it returns,+ "was deprecated in tern 0.9.3.\n ", |
||
| 300 | -+ | |||
| 192 | +! |
- #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned.+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 301 | +193 |
- #'+ ) |
||
| 302 | -+ | |||
| 194 | +! |
- #' @examples+ variables[["strata"]] <- variables[["strat"]] |
||
| 303 | +195 |
- #' format_fun <- format_fraction_threshold(0.05)+ } |
||
| 304 | +196 |
- #' format_fun(x = c(20, 0.1))+ |
||
| 305 | -+ | |||
| 197 | +5x |
- #' format_fun(x = c(2, 0.01))+ assert_list_of_variables(variables) |
||
| 306 | -+ | |||
| 198 | +5x |
- #' format_fun(x = c(0, 0))+ checkmate::assert_string(variables$rsp) |
||
| 307 | -+ | |||
| 199 | +5x |
- #'+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 308 | -+ | |||
| 200 | +5x |
- #' @family formatting functions+ checkmate::assert_string(label_all) |
||
| 309 | +201 |
- #' @export+ |
||
| 310 | +202 |
- format_fraction_threshold <- function(threshold) {
+ # Start with all patients. |
||
| 311 | -1x | +203 | +5x |
- assert_proportion_value(threshold)+ result_all <- h_logistic_mult_cont_df( |
| 312 | -1x | +204 | +5x |
- string_below_threshold <- paste0("<", round(threshold * 100))
+ variables = variables, |
| 313 | -1x | +205 | +5x |
- function(x, ...) {
+ data = data, |
| 314 | -3x | +206 | +5x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ control = control |
| 315 | -3x | +|||
| 207 | +
- ifelse(+ ) |
|||
| 316 | -3x | +208 | +5x |
- x[2] > 0.01,+ result_all$subgroup <- label_all |
| 317 | -3x | +209 | +5x |
- round(x[2] * 100),+ result_all$var <- "ALL" |
| 318 | -3x | +210 | +5x |
- ifelse(+ result_all$var_label <- label_all |
| 319 | -3x | +211 | +5x |
- x[2] == 0,+ result_all$row_type <- "content" |
| 320 | -3x | +212 | +5x |
- "0",+ if (is.null(variables$subgroups)) {
+ |
+
| 213 | ++ |
+ # Only return result for all patients. |
||
| 321 | -3x | +214 | +1x |
- string_below_threshold+ result_all |
| 322 | +215 |
- )+ } else {
|
||
| 323 | +216 |
- )+ # Add subgroups results. |
||
| 324 | -+ | |||
| 217 | +4x |
- }+ l_data <- h_split_by_subgroups( |
||
| 325 | -+ | |||
| 218 | +4x |
- }+ data, |
||
| 326 | -+ | |||
| 219 | +4x |
-
+ variables$subgroups, |
||
| 327 | -+ | |||
| 220 | +4x |
- #' Formatting Extreme Values+ groups_lists = groups_lists |
||
| 328 | +221 |
- #'+ ) |
||
| 329 | -+ | |||
| 222 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ l_result <- lapply(l_data, function(grp) {
|
||
| 330 | -+ | |||
| 223 | +20x |
- #'+ result <- h_logistic_mult_cont_df( |
||
| 331 | -+ | |||
| 224 | +20x |
- #' `rtables` formatting functions that handle extreme values.+ variables = variables, |
||
| 332 | -+ | |||
| 225 | +20x |
- #'+ data = grp$df, |
||
| 333 | -+ | |||
| 226 | +20x |
- #' @param digits (`integer`)\cr number of decimal places to display.+ control = control |
||
| 334 | +227 |
- #'+ ) |
||
| 335 | -+ | |||
| 228 | +20x |
- #' @details For each input, apply a format to the specified number of `digits`. If the value is+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
||
| 336 | -+ | |||
| 229 | +20x |
- #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is+ cbind(result, result_labels) |
||
| 337 | +230 |
- #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2.+ }) |
||
| 338 | -+ | |||
| 231 | +4x |
- #' If it is zero, then returns "0.00".+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 339 | -+ | |||
| 232 | +4x |
- #'+ result_subgroups$row_type <- "analysis" |
||
| 340 | -+ | |||
| 233 | +4x |
- #' @family formatting functions+ rbind( |
||
| 341 | -+ | |||
| 234 | +4x |
- #' @name extreme_format+ result_all,+ |
+ ||
| 235 | +4x | +
+ result_subgroups |
||
| 342 | +236 |
- NULL+ ) |
||
| 343 | +237 |
-
+ } |
||
| 344 | +238 |
- #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings+ } |
| 345 | +1 |
- #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`.+ #' Pairwise `CoxPH` model |
||
| 346 | +2 |
#' |
||
| 347 | +3 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
||
| 348 | +4 |
- #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds,+ #' |
||
| 349 | +5 |
- #' and `format_string`, with thresholds formatted as strings.+ #' Summarize p-value, HR and CIs from stratified or unstratified `CoxPH` model. |
||
| 350 | +6 |
#' |
||
| 351 | +7 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 352 | +8 |
- #' h_get_format_threshold(2L)+ #' @inheritParams s_surv_time |
||
| 353 | +9 |
- #'+ #' @param strata (`character` or `NULL`)\cr variable names indicating stratification factors. |
||
| 354 | +10 |
- #' @export+ #' @param strat `r lifecycle::badge("deprecated")` Please use the `strata` argument instead.
|
||
| 355 | +11 |
- h_get_format_threshold <- function(digits = 2L) {
- |
- ||
| 356 | -1498x | -
- checkmate::assert_integerish(digits)+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 357 | +12 |
-
+ #' [control_coxph()]. Some possible parameter options are: |
||
| 358 | -1498x | +|||
| 13 | +
- low_threshold <- 1 / (10 ^ digits) # styler: off+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. Default method is `"log-rank"` which |
|||
| 359 | -1498x | +|||
| 14 | +
- high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off+ #' comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` (from [survival::coxph()]). |
|||
| 360 | +15 |
-
+ #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`, |
||
| 361 | -1498x | +|||
| 16 | +
- string_below_threshold <- paste0("<", low_threshold)
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()] |
- |||
| 362 | -1498x | +|||
| 17 | +
- string_above_threshold <- paste0(">", high_threshold)
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
|||
| 363 | +18 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("coxph_pairwise")`
|
||
| 364 | -1498x | +|||
| 19 | +
- list(+ #' to see available statistics for this function. |
|||
| 365 | -1498x | +|||
| 20 | +
- "threshold" = c(low = low_threshold, high = high_threshold),+ #' |
|||
| 366 | -1498x | +|||
| 21 | +
- "format_string" = c(low = string_below_threshold, high = string_above_threshold)+ #' @name survival_coxph_pairwise |
|||
| 367 | +22 |
- )+ #' @order 1 |
||
| 368 | +23 |
- }+ NULL |
||
| 369 | +24 | |||
| 370 | +25 |
- #' @describeIn extreme_format Internal helper function to apply a threshold format to a value.+ #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR and p-value of a `coxph` model. |
||
| 371 | +26 |
- #' Creates a formatted string to be used in Formatting Functions.+ #' |
||
| 372 | +27 |
- #'+ #' @return |
||
| 373 | +28 |
- #' @param x (`number`)\cr value to format.+ #' * `s_coxph_pairwise()` returns the statistics: |
||
| 374 | +29 |
- #'+ #' * `pvalue`: p-value to test HR = 1. |
||
| 375 | +30 |
- #' @return+ #' * `hr`: Hazard ratio. |
||
| 376 | +31 |
- #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation+ #' * `hr_ci`: Confidence interval for hazard ratio. |
||
| 377 | +32 |
- #' of the given value to the digit threshold, as a formatted string.+ #' * `n_tot`: Total number of observations. |
||
| 378 | +33 |
- #'+ #' * `n_tot_events`: Total number of events. |
||
| 379 | +34 |
- #' @examples+ #' |
||
| 380 | +35 |
- #' h_format_threshold(0.001)+ #' @keywords internal |
||
| 381 | +36 |
- #' h_format_threshold(1000)+ s_coxph_pairwise <- function(df, |
||
| 382 | +37 |
- #'+ .ref_group, |
||
| 383 | +38 |
- #' @export+ .in_ref_col, |
||
| 384 | +39 |
- h_format_threshold <- function(x, digits = 2L) {
+ .var, |
||
| 385 | -1501x | +|||
| 40 | +
- if (is.na(x)) {
+ is_event, |
|||
| 386 | -4x | +|||
| 41 | +
- return(x)+ strata = NULL, |
|||
| 387 | +42 |
- }+ strat = lifecycle::deprecated(), |
||
| 388 | +43 |
-
+ control = control_coxph()) {
|
||
| 389 | -1497x | +44 | +71x |
- checkmate::assert_numeric(x, lower = 0)+ if (lifecycle::is_present(strat)) {
|
| 390 | -+ | |||
| 45 | +! |
-
+ lifecycle::deprecate_warn("0.9.3", "s_coxph_pairwise(strat)", "s_coxph_pairwise(strata)")
|
||
| 391 | -1497x | +|||
| 46 | +! |
- l_fmt <- h_get_format_threshold(digits)+ strata <- strat |
||
| 392 | +47 | ++ |
+ }+ |
+ |
| 48 | ||||
| 393 | -1497x | +49 | +71x |
- result <- if (x < l_fmt$threshold["low"] && 0 < x) {
+ checkmate::assert_string(.var) |
| 394 | -33x | +50 | +71x |
- l_fmt$format_string["low"]+ checkmate::assert_numeric(df[[.var]]) |
| 395 | -1497x | +51 | +71x |
- } else if (x > l_fmt$threshold["high"]) {
+ checkmate::assert_logical(df[[is_event]]) |
| 396 | -80x | +52 | +71x |
- l_fmt$format_string["high"]+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 397 | -+ | |||
| 53 | +71x |
- } else {
+ pval_method <- control$pval_method |
||
| 398 | -1384x | +54 | +71x |
- sprintf(fmt = paste0("%.", digits, "f"), x)
+ ties <- control$ties |
| 399 | -+ | |||
| 55 | +71x |
- }+ conf_level <- control$conf_level |
||
| 400 | +56 | |||
| 401 | -1497x | -
- unname(result)- |
- ||
| 402 | -+ | 57 | +71x |
- }+ if (.in_ref_col) {
|
| 403 | -+ | |||
| 58 | +! |
-
+ return( |
||
| 404 | -+ | |||
| 59 | +! |
- #' Formatting a Single Extreme Value+ list( |
||
| 405 | -+ | |||
| 60 | +! |
- #'+ pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
|
||
| 406 | -+ | |||
| 61 | +! |
- #' @description `r lifecycle::badge("stable")`
+ hr = formatters::with_label("", "Hazard Ratio"),
|
||
| 407 | -+ | |||
| 62 | +! |
- #'+ hr_ci = formatters::with_label("", f_conf_level(conf_level)),
|
||
| 408 | -+ | |||
| 63 | +! |
- #' Create Formatting Function for a single extreme value.+ n_tot = formatters::with_label("", "Total n"),
|
||
| 409 | -+ | |||
| 64 | +! |
- #'+ n_tot_events = formatters::with_label("", "Total events")
|
||
| 410 | +65 |
- #' @inheritParams extreme_format+ ) |
||
| 411 | +66 |
- #'+ ) |
||
| 412 | +67 |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value.+ } |
||
| 413 | -+ | |||
| 68 | +71x |
- #'+ data <- rbind(.ref_group, df) |
||
| 414 | -+ | |||
| 69 | +71x |
- #' @examples+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
||
| 415 | +70 |
- #' format_fun <- format_extreme_values(2L)+ |
||
| 416 | -+ | |||
| 71 | +71x |
- #' format_fun(x = 0.127)+ df_cox <- data.frame( |
||
| 417 | -+ | |||
| 72 | +71x |
- #' format_fun(x = Inf)+ tte = data[[.var]], |
||
| 418 | -+ | |||
| 73 | +71x |
- #' format_fun(x = 0)+ is_event = data[[is_event]], |
||
| 419 | -+ | |||
| 74 | +71x |
- #' format_fun(x = 0.009)+ arm = group |
||
| 420 | +75 |
- #'+ ) |
||
| 421 | -+ | |||
| 76 | +71x |
- #' @family formatting functions+ if (is.null(strata)) {
|
||
| 422 | -+ | |||
| 77 | +64x |
- #' @export+ formula_cox <- survival::Surv(tte, is_event) ~ arm |
||
| 423 | +78 |
- format_extreme_values <- function(digits = 2L) {
+ } else {
|
||
| 424 | -31x | +79 | +7x |
- function(x, ...) {
+ formula_cox <- stats::as.formula( |
| 425 | -423x | -
- checkmate::assert_scalar(x, na.ok = TRUE)- |
- ||
| 426 | -+ | 80 | +7x |
-
+ paste0( |
| 427 | -423x | +81 | +7x |
- h_format_threshold(x = x, digits = digits)+ "survival::Surv(tte, is_event) ~ arm + strata(",
|
| 428 | -+ | |||
| 82 | +7x |
- }+ paste(strata, collapse = ","), |
||
| 429 | +83 |
- }+ ")" |
||
| 430 | +84 |
-
+ ) |
||
| 431 | +85 |
- #' Formatting Extreme Values Part of a Confidence Interval+ ) |
||
| 432 | -+ | |||
| 86 | +7x |
- #'+ df_cox <- cbind(df_cox, data[strata]) |
||
| 433 | +87 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 434 | -+ | |||
| 88 | +71x |
- #'+ cox_fit <- survival::coxph( |
||
| 435 | -+ | |||
| 89 | +71x |
- #' Formatting Function for extreme values part of a confidence interval. Values+ formula = formula_cox, |
||
| 436 | -+ | |||
| 90 | +71x |
- #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2.+ data = df_cox, |
||
| 437 | -+ | |||
| 91 | +71x |
- #'+ ties = ties |
||
| 438 | +92 |
- #' @inheritParams extreme_format+ ) |
||
| 439 | -+ | |||
| 93 | +71x |
- #'+ sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE) |
||
| 440 | -+ | |||
| 94 | +71x |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme+ orginal_survdiff <- survival::survdiff( |
||
| 441 | -+ | |||
| 95 | +71x |
- #' values confidence interval.+ formula_cox, |
||
| 442 | -+ | |||
| 96 | +71x |
- #'+ data = df_cox |
||
| 443 | +97 |
- #' @examples+ ) |
||
| 444 | -+ | |||
| 98 | +71x |
- #' format_fun <- format_extreme_values_ci(2L)+ log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1) |
||
| 445 | +99 |
- #' format_fun(x = c(0.127, Inf))+ |
||
| 446 | -+ | |||
| 100 | +71x |
- #' format_fun(x = c(0, 0.009))+ pval <- switch(pval_method, |
||
| 447 | -+ | |||
| 101 | +71x |
- #'+ "wald" = sum_cox$waldtest["pvalue"], |
||
| 448 | -+ | |||
| 102 | +71x |
- #' @family formatting functions+ "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff() |
||
| 449 | -+ | |||
| 103 | +71x |
- #' @export+ "likelihood" = sum_cox$logtest["pvalue"] |
||
| 450 | +104 |
- format_extreme_values_ci <- function(digits = 2L) {
+ ) |
||
| 451 | -39x | +105 | +71x |
- function(x, ...) {
+ list( |
| 452 | -536x | +106 | +71x |
- checkmate::assert_vector(x, len = 2)+ pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
|
| 453 | -536x | +107 | +71x |
- l_result <- h_format_threshold(x = x[1], digits = digits)+ hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"), |
| 454 | -536x | +108 | +71x |
- h_result <- h_format_threshold(x = x[2], digits = digits)+ hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)), |
| 455 | -+ | |||
| 109 | +71x |
-
+ n_tot = formatters::with_label(sum_cox$n, "Total n"), |
||
| 456 | -536x | +110 | +71x |
- paste0("(", l_result, ", ", h_result, ")")
+ n_tot_events = formatters::with_label(sum_cox$nevent, "Total events") |
| 457 | +111 |
- }+ ) |
||
| 458 | +112 |
} |
||
| 459 | +113 | |||
| 460 | +114 |
- #' Automatic formats from data significant digits+ #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`. |
||
| 461 | +115 |
#' |
||
| 462 | +116 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 463 | +117 |
- #'+ #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 464 | +118 |
- #' Formatting function for the majority of default methods used in [analyze_vars()].+ #' |
||
| 465 | +119 |
- #' For non-derived values, the significant digits of data is used (e.g. range), while derived+ #' @keywords internal |
||
| 466 | +120 |
- #' values have one more digits (measure of location and dispersion like mean, standard deviation).+ a_coxph_pairwise <- make_afun( |
||
| 467 | +121 |
- #' This function can be called internally with "auto" like, for example,+ s_coxph_pairwise, |
||
| 468 | +122 |
- #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
+ .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L), |
||
| 469 | +123 |
- #'+ .formats = c( |
||
| 470 | +124 |
- #' @param dt_var (`numeric`) \cr all the data the statistics was created upon. Used only to find+ pvalue = "x.xxxx | (<0.0001)", |
||
| 471 | +125 |
- #' significant digits. In [analyze_vars] this comes from `.df_row` (see+ hr = "xx.xx", |
||
| 472 | +126 |
- #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No+ hr_ci = "(xx.xx, xx.xx)", |
||
| 473 | +127 |
- #' column split is considered.+ n_tot = "xx.xx", |
||
| 474 | +128 |
- #' @param x_stat (`string`) \cr string indicating the current statistical method used.+ n_tot_events = "xx.xx" |
||
| 475 | +129 |
- #'+ ) |
||
| 476 | +130 |
- #' @return A string that `rtables` prints in a table cell.+ ) |
||
| 477 | +131 |
- #'+ |
||
| 478 | +132 |
- #' @details+ #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments |
||
| 479 | +133 |
- #' The internal function is needed to work with `rtables` default structure for+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 480 | +134 |
- #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation.+ #' |
||
| 481 | +135 |
- #' It can be more than one element (e.g. for `.stats = "mean_sd"`).+ #' @return |
||
| 482 | +136 |
- #'+ #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions, |
||
| 483 | +137 |
- #' @examples+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 484 | +138 |
- #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4)+ #' the statistics from `s_coxph_pairwise()` to the table layout. |
||
| 485 | +139 |
- #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3]))+ #' |
||
| 486 | +140 |
- #'+ #' @examples |
||
| 487 | +141 |
- #' # x is the result coming into the formatting function -> res!!+ #' library(dplyr) |
||
| 488 | +142 |
- #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res)+ #' |
||
| 489 | +143 |
- #' format_auto(x_todo, "range")(x = range(x_todo))+ #' adtte_f <- tern_ex_adtte %>% |
||
| 490 | +144 |
- #' no_sc_x <- c(0.0000001, 1)+ #' filter(PARAMCD == "OS") %>% |
||
| 491 | +145 |
- #' format_auto(no_sc_x, "range")(x = no_sc_x)+ #' mutate(is_event = CNSR == 0) |
||
| 492 | +146 |
#' |
||
| 493 | +147 |
- #' @family formatting functions+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 494 | +148 |
- #' @export+ #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B") |
||
| 495 | +149 |
- format_auto <- function(dt_var, x_stat) {
- |
- ||
| 496 | -8x | -
- function(x = "", ...) {
- |
- ||
| 497 | -12x | -
- checkmate::assert_numeric(x, min.len = 1)- |
- ||
| 498 | -12x | -
- checkmate::assert_numeric(dt_var, min.len = 1)+ #' |
||
| 499 | +150 |
- # Defaults - they may be a param in the future- |
- ||
| 500 | -12x | -
- der_stats <- c(- |
- ||
| 501 | -12x | -
- "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",- |
- ||
| 502 | -12x | -
- "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi",- |
- ||
| 503 | -12x | -
- "median_ci"+ #' basic_table() %>% |
||
| 504 | +151 |
- )- |
- ||
| 505 | -12x | -
- nonder_stats <- c("n", "range", "min", "max")
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 506 | +152 |
-
+ #' add_colcounts() %>% |
||
| 507 | +153 |
- # Safenet for miss-modifications- |
- ||
| 508 | -12x | -
- stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint- |
- ||
| 509 | -12x | -
- checkmate::assert_choice(x_stat, c(der_stats, nonder_stats))+ #' coxph_pairwise( |
||
| 510 | +154 |
-
+ #' vars = "AVAL", |
||
| 511 | +155 |
- # Finds the max number of digits in data- |
- ||
| 512 | -12x | -
- detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>%- |
- ||
| 513 | -12x | -
- max()+ #' is_event = "is_event", |
||
| 514 | +156 | - - | -||
| 515 | -12x | -
- if (x_stat %in% der_stats) {
- |
- ||
| 516 | -5x | -
- detect_dig <- detect_dig + 1+ #' var_labels = "Unstratified Analysis" |
||
| 517 | +157 |
- }+ #' ) %>% |
||
| 518 | +158 |
-
+ #' build_table(df = adtte_f) |
||
| 519 | +159 |
- # Render input- |
- ||
| 520 | -12x | -
- str_vals <- formatC(x, digits = detect_dig, format = "f")- |
- ||
| 521 | -12x | -
- def_fmt <- get_formats_from_stats(x_stat)[[x_stat]]- |
- ||
| 522 | -12x | -
- str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]]- |
- ||
| 523 | -12x | -
- if (length(str_fmt) != length(str_vals)) {
- |
- ||
| 524 | -2x | -
- stop(- |
- ||
| 525 | -2x | -
- "Number of inserted values as result (", length(str_vals),
- |
- ||
| 526 | -2x | -
- ") is not the same as there should be in the default tern formats for ",- |
- ||
| 527 | -2x | -
- x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ",- |
- ||
| 528 | -2x | -
- "See tern_default_formats to check all of them."+ #' |
||
| 529 | +160 |
- )+ #' basic_table() %>% |
||
| 530 | +161 |
- }+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 531 | +162 |
-
+ #' add_colcounts() %>% |
||
| 532 | +163 |
- # Squashing them together- |
- ||
| 533 | -10x | -
- inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]- |
- ||
| 534 | -10x | -
- stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint+ #' coxph_pairwise( |
||
| 535 | +164 |
-
+ #' vars = "AVAL", |
||
| 536 | -10x | +|||
| 165 | +
- out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
+ #' is_event = "is_event", |
|||
| 537 | -10x | +|||
| 166 | +
- is_even <- seq_along(out) %% 2 == 0+ #' var_labels = "Stratified Analysis", |
|||
| 538 | -10x | +|||
| 167 | +
- out[is_even] <- str_vals+ #' strata = "SEX", |
|||
| 539 | -10x | +|||
| 168 | +
- out[!is_even] <- inv_str_fmt+ #' control = control_coxph(pval_method = "wald") |
|||
| 540 | +169 |
-
+ #' ) %>% |
||
| 541 | -10x | +|||
| 170 | +
- return(paste0(out, collapse = ""))+ #' build_table(df = adtte_f) |
|||
| 542 | +171 |
- }+ #' |
||
| 543 | +172 |
- }+ #' @export |
||
| 544 | +173 |
-
+ #' @order 2 |
||
| 545 | +174 |
- # Utility function that could be useful in general+ coxph_pairwise <- function(lyt, |
||
| 546 | +175 |
- str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
+ vars, |
||
| 547 | -22x | +|||
| 176 | +
- regmatches(string, gregexpr(pattern, string), invert = invert)+ na_str = default_na_str(), |
|||
| 548 | +177 |
- }+ nested = TRUE, |
||
| 549 | +178 |
-
+ ..., |
||
| 550 | +179 |
- # Helper function+ var_labels = "CoxPH", |
||
| 551 | +180 |
- count_decimalplaces <- function(dec) {
+ show_labels = "visible", |
||
| 552 | -125x | +|||
| 181 | +
- if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
+ table_names = vars, |
|||
| 553 | -104x | +|||
| 182 | +
- nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]])+ .stats = c("pvalue", "hr", "hr_ci"),
|
|||
| 554 | +183 |
- } else {
+ .formats = NULL, |
||
| 555 | -21x | +|||
| 184 | +
- return(0)+ .labels = NULL, |
|||
| 556 | +185 |
- }+ .indent_mods = NULL) {
|
||
| 557 | -+ | |||
| 186 | +5x |
- }+ extra_args <- list(...) |
||
| 558 | +187 | |||
| 559 | -+ | |||
| 188 | +5x |
- #' Apply Auto Formatting+ afun <- make_afun( |
||
| 560 | -+ | |||
| 189 | +5x |
- #'+ a_coxph_pairwise, |
||
| 561 | -+ | |||
| 190 | +5x |
- #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with+ .stats = .stats, |
||
| 562 | -+ | |||
| 191 | +5x |
- #' the correct implementation of `format_auto` for the given statistics, data, and variable.+ .formats = .formats, |
||
| 563 | -+ | |||
| 192 | +5x |
- #'+ .labels = .labels, |
||
| 564 | -+ | |||
| 193 | +5x |
- #' @inheritParams argument_convention+ .indent_mods = .indent_mods |
||
| 565 | +194 |
- #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds+ ) |
||
| 566 | -+ | |||
| 195 | +5x |
- #' to an element in `.formats`, with matching names.+ analyze( |
||
| 567 | -+ | |||
| 196 | +5x |
- #'+ lyt, |
||
| 568 | -+ | |||
| 197 | +5x |
- #' @keywords internal+ vars, |
||
| 569 | -+ | |||
| 198 | +5x |
- apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
+ var_labels = var_labels, |
||
| 570 | -385x | +199 | +5x |
- is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))+ show_labels = show_labels, |
| 571 | -385x | +200 | +5x |
- if (any(is_auto_fmt)) {
+ table_names = table_names, |
| 572 | -2x | +201 | +5x |
- auto_stats <- x_stats[is_auto_fmt]+ afun = afun, |
| 573 | -2x | +202 | +5x |
- var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ na_str = na_str, |
| 574 | -2x | +203 | +5x |
- .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df)+ nested = nested, |
| 575 | -+ | |||
| 204 | +5x |
- }+ extra_args = extra_args |
||
| 576 | -385x | +|||
| 205 | +
- .formats+ ) |
|||
| 577 | +206 |
}@@ -163779,14 +165311,14 @@ tern coverage - 90.46% |
| 1 |
- #' Patient Counts with the Most Extreme Post-baseline Toxicity Grade per Direction of Abnormality+ #' Count the Number of Patients with Particular Flags |
|||
| 5 |
- #' Primary analysis variable `.var` indicates the toxicity grade (`factor`), and additional+ #' The primary analysis variable `.var` denotes the unique patient identifier. |
|||
| 6 |
- #' analysis variables are `id` (`character` or `factor`), `param` (`factor`) and `grade_dir` (`factor`).+ #' |
|||
| 7 |
- #' The pre-processing steps are crucial when using this function.+ #' @inheritParams argument_convention |
|||
| 8 |
- #' For a certain direction (e.g. high or low) this function counts+ #' @param flag_variables (`character`)\cr a character vector specifying the names of `logical` |
|||
| 9 |
- #' patients in the denominator as number of patients with at least one valid measurement during treatment,+ #' variables from analysis dataset used for counting the number of unique identifiers. |
|||
| 10 |
- #' and patients in the numerator as follows:+ #' @param flag_labels (`character`)\cr vector of labels to use for flag variables. |
|||
| 11 |
- #' * `1` to `4`: Numerator is number of patients with worst grades 1-4 respectively;+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_flags")`
|
|||
| 12 |
- #' * `Any`: Numerator is number of patients with at least one abnormality, which means grade is different from 0.+ #' to see available statistics for this function. |
|||
| 14 |
- #' Pre-processing is crucial when using this function and can be done automatically using the+ #' @seealso [count_patients_with_event] |
|||
| 15 |
- #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the+ #' |
|||
| 16 |
- #' necessary pre-processing steps.+ #' @name count_patients_with_flags |
|||
| 17 |
- #'+ #' @order 1 |
|||
| 18 |
- #' @inheritParams argument_convention+ NULL |
|||
| 19 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade")`
+
|
|||
| 20 |
- #' to see available statistics for this function.+ #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which |
|||
| 21 |
- #'+ #' a particular flag variable is `TRUE`. |
|||
| 22 |
- #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes `ADLB` data frames to be used in+ #' |
|||
| 23 |
- #' [count_abnormal_by_worst_grade()].+ #' @inheritParams analyze_variables |
|||
| 24 |
- #'+ #' @param .var (`character`)\cr name of the column that contains the unique identifier. |
|||
| 25 |
- #' @name abnormal_by_worst_grade+ #' |
|||
| 26 |
- #' @order 1+ #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not |
|||
| 27 |
- NULL+ #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to |
|||
| 28 |
-
+ #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is |
|||
| 29 |
- #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade.+ #' the label to use for this variable. |
|||
| 32 |
- #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and+ #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular |
|||
| 33 |
- #' "Any" results.+ #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag. |
|||
| 35 |
- #' @keywords internal+ #' @examples |
|||
| 36 |
- s_count_abnormal_by_worst_grade <- function(df, # nolint+ #' # `s_count_patients_with_flags()` |
|||
| 37 |
- .var = "GRADE_ANL",+ #' |
|||
| 38 |
- .spl_context,+ #' s_count_patients_with_flags( |
|||
| 39 |
- variables = list(+ #' adae, |
|||
| 40 |
- id = "USUBJID",+ #' "SUBJID", |
|||
| 41 |
- param = "PARAM",+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
|||
| 42 |
- grade_dir = "GRADE_DIR"+ #' denom = "N_col", |
|||
| 43 |
- )) {
+ #' .N_col = 1000 |
|||
| 44 | -1x | +
- checkmate::assert_string(.var)+ #' ) |
||
| 45 | -1x | +
- assert_valid_factor(df[[.var]])+ #' |
||
| 46 | -1x | +
- assert_valid_factor(df[[variables$param]])+ #' @export |
||
| 47 | -1x | +
- assert_valid_factor(df[[variables$grade_dir]])+ s_count_patients_with_flags <- function(df, |
||
| 48 | -1x | +
- assert_df_with_variables(df, c(a = .var, variables))+ .var, |
||
| 49 | -1x | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ flag_variables, |
||
| 50 |
-
+ flag_labels = NULL, |
|||
| 51 |
- # To verify that the `split_rows_by` are performed with correct variables.+ .N_col, # nolint |
|||
| 52 | -1x | +
- checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)+ .N_row, # nolint |
||
| 53 | -1x | +
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ denom = c("n", "N_row", "N_col")) {
|
||
| 54 | -1x | +5x |
- x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ checkmate::assert_character(flag_variables) |
|
| 55 | -1x | +5x |
- result <- split(numeric(0), factor(x_lvls))+ if (!is.null(flag_labels)) {
|
|
| 56 | -+ | ! |
-
+ checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE) |
|
| 57 | -1x | +! |
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ flag_names <- flag_labels |
|
| 58 | -1x | +
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ } else {
|
||
| 59 | -+ | 5x |
- # Some subjects may have a record for high and low directions but+ if (is.null(names(flag_variables))) {
|
|
| 60 | -+ | 5x |
- # should be counted only once.+ flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE) |
|
| 61 | -1x | +
- denom <- length(unique(subj_cur_col))+ } else {
|
||
| 62 | -+ | ! |
-
+ flag_names <- unname(flag_variables) |
|
| 63 | -1x | +! |
- for (lvl in x_lvls) {
+ flag_variables <- names(flag_variables) |
|
| 64 | -5x | +
- if (lvl != "Any") {
+ } |
||
| 65 | -4x | +
- df_lvl <- df[df[[.var]] == lvl, ]+ } |
||
| 66 |
- } else {
+
|
|||
| 67 | -1x | +5x |
- df_lvl <- df[df[[.var]] != 0, ]+ checkmate::assert_subset(flag_variables, colnames(df)) |
|
| 68 | -+ | 5x |
- }+ temp <- sapply(flag_variables, function(x) {
|
|
| 69 | -5x | +11x |
- num <- length(unique(df_lvl[[variables[["id"]]]]))+ tmp <- Map(function(y) which(df[[y]]), x) |
|
| 70 | -5x | +11x |
- fraction <- ifelse(denom == 0, 0, num / denom)+ position_satisfy_flags <- Reduce(intersect, tmp) |
|
| 71 | -5x | +11x |
- result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)+ id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]])) |
|
| 72 | -+ | 11x |
- }+ s_count_values( |
|
| 73 | -+ | 11x |
-
+ as.character(unique(df[[.var]])), |
|
| 74 | -1x | +11x |
- result <- list(count_fraction = result)+ id_satisfy_flags, |
|
| 75 | -1x | +11x |
- result+ denom = denom, |
|
| 76 | -+ | 11x |
- }+ .N_col = .N_col, |
|
| 77 | -+ | 11x |
-
+ .N_row = .N_row |
|
| 78 |
- #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun`+ ) |
|||
| 79 |
- #' in `count_abnormal_by_worst_grade()`.+ }) |
|||
| 80 | -+ | 5x |
- #'+ colnames(temp) <- flag_names |
|
| 81 | -+ | 5x |
- #' @return+ temp <- data.frame(t(temp)) |
|
| 82 | -+ | 5x |
- #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ result <- temp %>% as.list() |
|
| 83 | -+ | 5x |
- #'+ if (length(flag_variables) == 1) {
|
|
| 84 | -+ | 1x |
- #' @keywords internal+ for (i in 1:3) names(result[[i]]) <- flag_names[1] |
|
| 85 |
- a_count_abnormal_by_worst_grade <- make_afun( # nolint+ } |
|||
| 86 | -+ | 5x |
- s_count_abnormal_by_worst_grade,+ result |
|
| 87 |
- .formats = c(count_fraction = format_count_fraction)+ } |
|||
| 88 |
- )+ |
|||
| 89 |
-
+ #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun` |
|||
| 90 |
- #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments+ #' in `count_patients_with_flags()`. |
|||
| 91 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
|||
| 92 |
- #'+ #' @return |
|||
| 93 |
- #' @return+ #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 94 |
- #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions,+ #' |
|||
| 95 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @examples |
|||
| 96 |
- #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout.+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting |
|||
| 97 |
- #'+ #' # function `format_count_fraction()` can be applied correctly. |
|||
| 98 |
- #' @examples+ #' |
|||
| 99 |
- #' library(dplyr)+ #' # `a_count_patients_with_flags()` |
|||
| 100 |
- #' library(forcats)+ #' |
|||
| 101 |
- #' adlb <- tern_ex_adlb+ #' afun <- make_afun(a_count_patients_with_flags, |
|||
| 102 |
- #'+ #' .stats = "count_fraction", |
|||
| 103 |
- #' # Data is modified in order to have some parameters with grades only in one direction+ #' .ungroup_stats = "count_fraction" |
|||
| 104 |
- #' # and simulate the real data.+ #' ) |
|||
| 105 |
- #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
+ #' afun( |
|||
| 106 |
- #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"+ #' adae, |
|||
| 107 |
- #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""+ #' .N_col = 10L, |
|||
| 108 |
- #'+ #' .N_row = 10L, |
|||
| 109 |
- #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
+ #' .var = "USUBJID", |
|||
| 110 |
- #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
|
|||
| 111 |
- #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""+ #' ) |
|||
| 113 |
- #' # Pre-processing+ #' @export |
|||
| 114 |
- #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade()+ a_count_patients_with_flags <- make_afun( |
|||
| 115 |
- #'+ s_count_patients_with_flags, |
|||
| 116 |
- #' # Map excludes records without abnormal grade since they should not be displayed+ .formats = c("count_fraction" = format_count_fraction_fixed_dp)
|
|||
| 117 |
- #' # in the table.+ ) |
|||
| 118 |
- #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
+
|
|||
| 119 |
- #' lapply(as.character) %>%+ #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function |
|||
| 120 |
- #' as.data.frame() %>%+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 121 |
- #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)+ #' |
|||
| 122 |
- #'+ #' @return |
|||
| 123 |
- #' basic_table() %>%+ #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions, |
|||
| 124 |
- #' split_cols_by("ARMCD") %>%
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 125 |
- #' split_rows_by("PARAM") %>%
+ #' the statistics from `s_count_patients_with_flags()` to the table layout. |
|||
| 126 |
- #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
+ #' |
|||
| 127 |
- #' count_abnormal_by_worst_grade(+ #' @examples |
|||
| 128 |
- #' var = "GRADE_ANL",+ #' library(dplyr) |
|||
| 129 |
- #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")+ #' |
|||
| 130 |
- #' ) %>%+ #' # Add labelled flag variables to analysis dataset. |
|||
| 131 |
- #' build_table(df = adlb_f)+ #' adae <- tern_ex_adae %>% |
|||
| 132 |
- #'+ #' mutate( |
|||
| 133 |
- #' @export+ #' fl1 = TRUE %>% with_label("Total AEs"),
|
|||
| 134 |
- #' @order 2+ #' fl2 = (TRTEMFL == "Y") %>% |
|||
| 135 |
- count_abnormal_by_worst_grade <- function(lyt,+ #' with_label("Total number of patients with at least one adverse event"),
|
|||
| 136 |
- var,+ #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>% |
|||
| 137 |
- variables = list(+ #' with_label("Total number of patients with fatal AEs"),
|
|||
| 138 |
- id = "USUBJID",+ #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>% |
|||
| 139 |
- param = "PARAM",+ #' with_label("Total number of patients with related fatal AEs")
|
|||
| 140 |
- grade_dir = "GRADE_DIR"+ #' ) |
|||
| 141 |
- ),+ #' |
|||
| 142 |
- na_str = default_na_str(),+ #' # `count_patients_with_flags()` |
|||
| 143 |
- nested = TRUE,+ #' |
|||
| 144 |
- ...,+ #' lyt2 <- basic_table() %>% |
|||
| 145 |
- .stats = NULL,+ #' split_cols_by("ARM") %>%
|
|||
| 146 |
- .formats = NULL,+ #' add_colcounts() %>% |
|||
| 147 |
- .labels = NULL,+ #' count_patients_with_flags( |
|||
| 148 |
- .indent_mods = NULL) {
+ #' "SUBJID", |
|||
| 149 | -2x | +
- extra_args <- list(variables = variables, ...)+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
||
| 150 |
-
+ #' denom = "N_col" |
|||
| 151 | -2x | +
- afun <- make_afun(+ #' ) |
||
| 152 | -2x | +
- a_count_abnormal_by_worst_grade,+ #' |
||
| 153 | -2x | +
- .stats = .stats,+ #' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl) |
||
| 154 | -2x | +
- .formats = .formats,+ #' |
||
| 155 | -2x | +
- .labels = .labels,+ #' @export |
||
| 156 | -2x | +
- .indent_mods = .indent_mods,+ #' @order 2 |
||
| 157 | -2x | +
- .ungroup_stats = "count_fraction"+ count_patients_with_flags <- function(lyt, |
||
| 158 |
- )+ var, |
|||
| 159 | -2x | +
- analyze(+ flag_variables, |
||
| 160 | -2x | +
- lyt = lyt,+ flag_labels = NULL, |
||
| 161 | -2x | +
- vars = var,+ var_labels = var, |
||
| 162 | -2x | +
- afun = afun,+ show_labels = "hidden", |
||
| 163 | -2x | +
- na_str = na_str,+ riskdiff = FALSE, |
||
| 164 | -2x | +
- nested = nested,+ na_str = default_na_str(), |
||
| 165 | -2x | +
- extra_args = extra_args,+ nested = TRUE, |
||
| 166 | -2x | +
- show_labels = "hidden"+ ..., |
||
| 167 |
- )+ table_names = paste0("tbl_flags_", var),
|
|||
| 168 |
- }+ .stats = "count_fraction", |
|||
| 169 |
-
+ .formats = NULL, |
|||
| 170 |
- #' Helper function to prepare `ADLB` for [count_abnormal_by_worst_grade()]+ .indent_mods = NULL) {
|
|||
| 171 | -+ | 6x |
- #'+ checkmate::assert_flag(riskdiff) |
|
| 172 |
- #' @description `r lifecycle::badge("stable")`
+
|
|||
| 173 | -+ | 6x |
- #'+ s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...) |
|
| 174 |
- #' Helper function to prepare an `ADLB` data frame to be used as input in+ |
|||
| 175 | -+ | 6x |
- #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied:+ afun <- make_afun( |
|
| 176 | -+ | 6x |
- #'+ a_count_patients_with_flags, |
|
| 177 | -+ | 6x |
- #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits.+ .stats = .stats, |
|
| 178 | -+ | 6x |
- #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only+ .formats = .formats, |
|
| 179 | -+ | 6x |
- #' worst grades (in either direction) are included.+ .indent_mods = .indent_mods, |
|
| 180 | -+ | 6x |
- #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived+ .ungroup_stats = .stats |
|
| 181 |
- #' and added to `adlb`:+ ) |
|||
| 182 |
- #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when+ |
|||
| 183 | -+ | 6x |
- #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise.+ extra_args <- if (isFALSE(riskdiff)) {
|
|
| 184 | -+ | 5x |
- #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are+ s_args |
|
| 185 |
- #' replaced by their absolute values.+ } else {
|
|||
| 186 | -+ | 1x |
- #' 4. Unused factor levels are dropped from `adlb` via [droplevels()].+ list( |
|
| 187 | -+ | 1x |
- #'+ afun = list("s_count_patients_with_flags" = afun),
|
|
| 188 | -+ | 1x |
- #' @param adlb (`data.frame`)\cr `ADLB` dataframe.+ .stats = .stats, |
|
| 189 | -+ | 1x |
- #' @param atoxgr (`character`)\cr Analysis toxicity grade variable. This must be a `factor`+ .indent_mods = .indent_mods, |
|
| 190 | -+ | 1x |
- #' variable.+ s_args = s_args |
|
| 191 |
- #' @param avisit (`character`)\cr Analysis visit variable.+ ) |
|||
| 192 |
- #' @param worst_flag_low (`character`)\cr Worst low lab grade flag variable. This variable is+ } |
|||
| 193 |
- #' set to `"Y"` when indicating records of worst low lab grades.- |
- |||
| 194 | -- |
- #' @param worst_flag_high (`character`)\cr Worst high lab grade flag variable. This variable is- |
- ||
| 195 | -- |
- #' set to `"Y"` when indicating records of worst high lab grades.- |
- ||
| 196 | -- |
- #'- |
- ||
| 197 | -- |
- #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new- |
- ||
| 198 | -- |
- #' variables: `GRADE_DIR` and `GRADE_ANL`.- |
- ||
| 199 | -- |
- #'- |
- ||
| 200 | -- |
- #' @seealso [abnormal_by_worst_grade]- |
- ||
| 201 | -- |
- #'- |
- ||
| 202 | -- |
- #' @examples- |
- ||
| 203 | -- |
- #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>%- |
- ||
| 204 | -- |
- #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>%- |
- ||
| 205 | -- |
- #' head(10)- |
- ||
| 206 | -- |
- #'- |
- ||
| 207 | -- |
- #' @export- |
- ||
| 208 | -- |
- h_adlb_abnormal_by_worst_grade <- function(adlb,- |
- ||
| 209 | -- |
- atoxgr = "ATOXGR",- |
- ||
| 210 | -- |
- avisit = "AVISIT",- |
- ||
| 211 | -- |
- worst_flag_low = "WGRLOFL",- |
- ||
| 212 | -- |
- worst_flag_high = "WGRHIFL") {
- |
- ||
| 213 | -1x | -
- adlb %>%- |
- ||
| 214 | -1x | -
- dplyr::filter(- |
- ||
| 215 | -1x | -
- !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
- |
- ||
| 216 | -1x | -
- .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y"- |
- ||
| 217 | -- |
- ) %>%- |
- ||
| 218 | -1x | -
- dplyr::mutate(- |
- ||
| 219 | -1x | -
- GRADE_DIR = factor(+ |
||
| 220 | -1x | +194 | +6x |
- dplyr::case_when(+ lyt <- analyze( |
| 221 | -1x | +195 | +6x |
- .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ lyt = lyt, |
| 222 | -1x | +196 | +6x |
- .data[[atoxgr]] == "0" ~ "ZERO",+ vars = var, |
| 223 | -1x | +197 | +6x |
- .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
+ var_labels = var_labels, |
| 224 | -+ | |||
| 198 | +6x |
- ),+ show_labels = show_labels, |
||
| 225 | -1x | +199 | +6x |
- levels = c("LOW", "ZERO", "HIGH")
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 226 | -+ | |||
| 200 | +6x |
- ),+ table_names = table_names, |
||
| 227 | -1x | +201 | +6x |
- GRADE_ANL = forcats::fct_relevel(+ na_str = na_str, |
| 228 | -1x | +202 | +6x |
- forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ nested = nested, |
| 229 | -1x | +203 | +6x |
- c("0", "1", "2", "3", "4")
+ extra_args = extra_args |
| 230 | +204 |
- )+ ) |
||
| 231 | +205 |
- ) %>%+ |
||
| 232 | -1x | +206 | +6x |
- droplevels()+ lyt |
| 233 | +207 |
}@@ -165416,14 +166766,14 @@ tern coverage - 90.46% |
| 1 |
- #' Helper Functions for Tabulating Biomarker Effects on Binary Response by Subgroup+ #' Estimation of Proportions per Level of Factor |
|||
| 5 |
- #' Helper functions which are documented here separately to not confuse the user+ #' Estimate the proportion along with confidence interval of a proportion |
|||
| 6 |
- #' when reading about the user-facing functions.+ #' regarding the level of a factor. |
|||
| 8 |
- #' @inheritParams response_biomarkers_subgroups+ #' @inheritParams argument_convention |
|||
| 9 |
- #' @inheritParams extract_rsp_biomarkers+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_multinomial_response")`
|
|||
| 10 |
- #' @inheritParams argument_convention+ #' to see available statistics for this function. |
|||
| 12 |
- #' @examples+ #' @seealso Relevant description function [d_onco_rsp_label()]. |
|||
| 13 |
- #' library(dplyr)+ #' |
|||
| 14 |
- #' library(forcats)+ #' @name estimate_multinomial_rsp |
|||
| 15 |
- #'+ #' @order 1 |
|||
| 16 |
- #' adrs <- tern_ex_adrs+ NULL |
|||
| 17 |
- #' adrs_labels <- formatters::var_labels(adrs)+ |
|||
| 18 |
- #'+ #' Description of Standard Oncology Response |
|||
| 19 |
- #' adrs_f <- adrs %>%+ #' |
|||
| 20 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' @description `r lifecycle::badge("stable")`
|
|||
| 21 |
- #' mutate(rsp = AVALC == "CR")+ #' |
|||
| 22 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' Describe the oncology response in a standard way. |
|||
| 24 |
- #' @name h_response_biomarkers_subgroups+ #' @param x (`character`)\cr the standard oncology code to be described. |
|||
| 25 |
- NULL+ #' |
|||
| 26 |
-
+ #' @return Response labels. |
|||
| 27 |
- #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list+ #' |
|||
| 28 |
- #' to the "logistic regression" variable list. The reason is that currently there is an+ #' @seealso [estimate_multinomial_rsp()] |
|||
| 29 |
- #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`.+ #' |
|||
| 30 |
- #'+ #' @examples |
|||
| 31 |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ #' d_onco_rsp_label( |
|||
| 32 |
- #'+ #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
|
|||
| 33 |
- #' @return+ #' ) |
|||
| 34 |
- #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`.+ #' |
|||
| 35 |
- #'+ #' # Adding some values not considered in d_onco_rsp_label |
|||
| 36 |
- #' @examples+ #' |
|||
| 37 |
- #' # This is how the variable list is converted internally.+ #' d_onco_rsp_label( |
|||
| 38 |
- #' h_rsp_to_logistic_variables(+ #' c("CR", "PR", "hello", "hi")
|
|||
| 39 |
- #' variables = list(+ #' ) |
|||
| 40 |
- #' rsp = "RSP",+ #' |
|||
| 41 |
- #' covariates = c("A", "B"),
+ #' @export |
|||
| 42 |
- #' strat = "D"+ d_onco_rsp_label <- function(x) {
|
|||
| 43 | -+ | 2x |
- #' ),+ x <- as.character(x) |
|
| 44 | -+ | 2x |
- #' biomarker = "AGE"+ desc <- c( |
|
| 45 | -+ | 2x |
- #' )+ CR = "Complete Response (CR)", |
|
| 46 | -+ | 2x |
- #'+ PR = "Partial Response (PR)", |
|
| 47 | -+ | 2x |
- #' @export+ MR = "Minimal/Minor Response (MR)", |
|
| 48 | -+ | 2x |
- h_rsp_to_logistic_variables <- function(variables, biomarker) {
+ MRD = "Minimal Residual Disease (MRD)", |
|
| 49 | -49x | +2x |
- checkmate::assert_list(variables)+ SD = "Stable Disease (SD)", |
|
| 50 | -49x | +2x |
- checkmate::assert_string(variables$rsp)+ PD = "Progressive Disease (PD)", |
|
| 51 | -49x | +2x |
- checkmate::assert_string(biomarker)+ `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)", |
|
| 52 | -49x | +2x |
- list(+ NE = "Not Evaluable (NE)", |
|
| 53 | -49x | +2x |
- response = variables$rsp,+ `NE/Missing` = "Missing or unevaluable", |
|
| 54 | -49x | +2x |
- arm = biomarker,+ Missing = "Missing", |
|
| 55 | -49x | +2x |
- covariates = variables$covariates,+ `NA` = "Not Applicable (NA)", |
|
| 56 | -49x | +2x |
- strata = variables$strat+ ND = "Not Done (ND)" |
|
| 58 |
- }+ |
|||
| 59 | -+ | 2x |
-
+ values_label <- vapply( |
|
| 60 | -+ | 2x |
- #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and+ X = x, |
|
| 61 | -+ | 2x |
- #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple+ FUN.VALUE = character(1), |
|
| 62 | -+ | 2x |
- #' biomarkers in a given single data set.+ function(val) {
|
|
| 63 | -+ | ! |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ if (val %in% names(desc)) desc[val] else val |
|
| 64 |
- #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`+ } |
|||
| 65 |
- #' and `strat`.+ ) |
|||
| 66 |
- #'+ |
|||
| 67 | -+ | 2x |
- #' @return+ return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc)))) |
|
| 68 |
- #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ } |
|||
| 69 |
- #'+ |
|||
| 70 |
- #' @examples+ #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number |
|||
| 71 |
- #' # For a single population, estimate separately the effects+ #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()]. |
|||
| 72 |
- #' # of two biomarkers.+ #' |
|||
| 73 |
- #' df <- h_logistic_mult_cont_df(+ #' @return |
|||
| 74 |
- #' variables = list(+ #' * `s_length_proportion()` returns statistics from [s_proportion()]. |
|||
| 75 |
- #' rsp = "rsp",+ #' |
|||
| 76 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @examples |
|||
| 77 |
- #' covariates = "SEX"+ #' s_length_proportion(rep("CR", 10), .N_col = 100)
|
|||
| 78 |
- #' ),+ #' s_length_proportion(factor(character(0)), .N_col = 100) |
|||
| 79 |
- #' data = adrs_f+ #' |
|||
| 80 |
- #' )+ #' @export |
|||
| 81 |
- #' df+ s_length_proportion <- function(x, |
|||
| 82 |
- #'+ .N_col, # nolint |
|||
| 83 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ ...) {
|
|||
| 84 | -+ | 4x |
- #' h_coxreg_mult_cont_df(+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
|
| 85 | -+ | 3x |
- #' variables = list(+ checkmate::assert_vector(x, min.len = 0, max.len = .N_col) |
|
| 86 | -+ | 2x |
- #' rsp = "rsp",+ checkmate::assert_vector(unique(x), min.len = 0, max.len = 1) |
|
| 87 |
- #' biomarkers = c("BMRKR1", "AGE"),
+
|
|||
| 88 | -+ | 1x |
- #' covariates = "SEX",+ n_true <- length(x) |
|
| 89 | -+ | 1x |
- #' strat = "STRATA1"+ n_false <- .N_col - n_true |
|
| 90 | -+ | 1x |
- #' ),+ x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false)) |
|
| 91 | -+ | 1x |
- #' data = adrs_f[NULL, ]+ s_proportion(df = x_logical, ...) |
|
| 92 |
- #' )+ } |
|||
| 93 |
- #'+ |
|||
| 94 |
- #' @export+ #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun` |
|||
| 95 |
- h_logistic_mult_cont_df <- function(variables,+ #' in `estimate_multinomial_response()`. |
|||
| 96 |
- data,+ #' |
|||
| 97 |
- control = control_logistic()) {
+ #' @return |
|||
| 98 | -28x | +
- assert_df_with_variables(data, variables)+ #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 99 |
-
+ #' |
|||
| 100 | -28x | +
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ #' @examples |
||
| 101 | -28x | +
- checkmate::assert_list(control, names = "named")+ #' a_length_proportion(rep("CR", 10), .N_col = 100)
|
||
| 102 |
-
+ #' a_length_proportion(factor(character(0)), .N_col = 100) |
|||
| 103 | -28x | +
- conf_level <- control[["conf_level"]]+ #' |
||
| 104 | -28x | +
- pval_label <- "p-value (Wald)"+ #' @export |
||
| 105 |
-
+ a_length_proportion <- make_afun( |
|||
| 106 |
- # If there is any data, run model, otherwise return empty results.+ s_length_proportion, |
|||
| 107 | -28x | +
- if (nrow(data) > 0) {
+ .formats = c( |
||
| 108 | -27x | +
- bm_cols <- match(variables$biomarkers, names(data))+ n_prop = "xx (xx.x%)", |
||
| 109 | -27x | +
- l_result <- lapply(variables$biomarkers, function(bm) {
+ prop_ci = "(xx.xx, xx.xx)" |
||
| 110 | -48x | +
- model_fit <- fit_logistic(+ ) |
||
| 111 | -48x | +
- variables = h_rsp_to_logistic_variables(variables, bm),+ ) |
||
| 112 | -48x | +
- data = data,+ |
||
| 113 | -48x | +
- response_definition = control$response_definition+ #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments |
||
| 114 |
- )+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and |
|||
| 115 | -48x | +
- result <- h_logistic_simple_terms(+ #' [rtables::summarize_row_groups()]. |
||
| 116 | -48x | +
- x = bm,+ #' |
||
| 117 | -48x | +
- fit_glm = model_fit,+ #' @return |
||
| 118 | -48x | +
- conf_level = control$conf_level+ #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions, |
||
| 119 |
- )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 120 | -48x | +
- resp_vector <- if (inherits(model_fit, "glm")) {
+ #' the statistics from `s_length_proportion()` to the table layout. |
||
| 121 | -38x | +
- model_fit$model[[variables$rsp]]+ #' |
||
| 122 |
- } else {
+ #' @examples |
|||
| 123 | -10x | +
- as.logical(as.matrix(model_fit$y)[, "status"])+ #' library(dplyr) |
||
| 124 |
- }+ #' |
|||
| 125 | -48x | +
- data.frame(+ #' # Use of the layout creating function. |
||
| 126 |
- # Dummy column needed downstream to create a nested header.+ #' dta_test <- data.frame( |
|||
| 127 | -48x | +
- biomarker = bm,+ #' USUBJID = paste0("S", 1:12),
|
||
| 128 | -48x | +
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ #' ARM = factor(rep(LETTERS[1:3], each = 4)), |
||
| 129 | -48x | +
- n_tot = length(resp_vector),+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0)) |
||
| 130 | -48x | -
- n_rsp = sum(resp_vector),- |
- ||
| 131 | -48x | -
- prop = mean(resp_vector),- |
- ||
| 132 | -48x | -
- or = as.numeric(result[1L, "odds_ratio"]),- |
- ||
| 133 | -48x | -
- lcl = as.numeric(result[1L, "lcl"]),- |
- ||
| 134 | -48x | -
- ucl = as.numeric(result[1L, "ucl"]),- |
- ||
| 135 | -48x | -
- conf_level = conf_level,- |
- ||
| 136 | -48x | -
- pval = as.numeric(result[1L, "pvalue"]),- |
- ||
| 137 | -48x | -
- pval_label = pval_label,- |
- ||
| 138 | -48x | +
- stringsAsFactors = FALSE+ #' ) %>% mutate( |
||
| 139 | +131 |
- )+ #' AVALC = factor(AVAL, |
||
| 140 | +132 |
- })- |
- ||
| 141 | -27x | -
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' levels = c(0, 1), |
||
| 142 | +133 |
- } else {
- |
- ||
| 143 | -1x | -
- data.frame(- |
- ||
| 144 | -1x | -
- biomarker = variables$biomarkers,- |
- ||
| 145 | -1x | -
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),- |
- ||
| 146 | -1x | -
- n_tot = 0L,- |
- ||
| 147 | -1x | -
- n_rsp = 0L,- |
- ||
| 148 | -1x | -
- prop = NA,- |
- ||
| 149 | -1x | -
- or = NA,- |
- ||
| 150 | -1x | -
- lcl = NA,- |
- ||
| 151 | -1x | -
- ucl = NA,- |
- ||
| 152 | -1x | -
- conf_level = conf_level,- |
- ||
| 153 | -1x | -
- pval = NA,- |
- ||
| 154 | -1x | -
- pval_label = pval_label,- |
- ||
| 155 | -1x | -
- row.names = seq_along(variables$biomarkers),- |
- ||
| 156 | -1x | -
- stringsAsFactors = FALSE+ #' labels = c("Complete Response (CR)", "Partial Response (PR)")
|
||
| 157 | +134 |
- )+ #' ) |
||
| 158 | +135 |
- }+ #' ) |
||
| 159 | +136 |
- }+ #' |
||
| 160 | +137 |
-
+ #' lyt <- basic_table() %>% |
||
| 161 | +138 |
- #' @describeIn h_response_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing+ #' split_cols_by("ARM") %>%
|
||
| 162 | +139 |
- #' the results for a single biomarker.+ #' estimate_multinomial_response(var = "AVALC") |
||
| 163 | +140 |
#' |
||
| 164 | +141 |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ #' tbl <- build_table(lyt, dta_test) |
||
| 165 | +142 |
- #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are+ #' |
||
| 166 | +143 |
- #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()],+ #' tbl |
||
| 167 | +144 |
- #' see the example).+ #' |
||
| 168 | +145 |
- #'+ #' @export |
||
| 169 | +146 |
- #' @return+ #' @order 2 |
||
| 170 | +147 |
- #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ estimate_multinomial_response <- function(lyt, |
||
| 171 | +148 |
- #'+ var, |
||
| 172 | +149 |
- #' @examples+ na_str = default_na_str(), |
||
| 173 | +150 |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ nested = TRUE, |
||
| 174 | +151 |
- #' df1 <- df[1, ]+ ..., |
||
| 175 | +152 |
- #' df1$subgroup <- "All patients"+ show_labels = "hidden", |
||
| 176 | +153 |
- #' df1$row_type <- "content"+ table_names = var, |
||
| 177 | +154 |
- #' df1$var <- "ALL"+ .stats = "prop_ci", |
||
| 178 | +155 |
- #' df1$var_label <- "All patients"+ .formats = NULL, |
||
| 179 | +156 |
- #'+ .labels = NULL, |
||
| 180 | +157 |
- #' h_tab_rsp_one_biomarker(+ .indent_mods = NULL) {
|
||
| 181 | -+ | |||
| 158 | +1x |
- #' df1,+ extra_args <- list(...) |
||
| 182 | +159 |
- #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
+
|
||
| 183 | -+ | |||
| 160 | +1x |
- #' )+ afun <- make_afun( |
||
| 184 | -+ | |||
| 161 | +1x |
- #'+ a_length_proportion, |
||
| 185 | -+ | |||
| 162 | +1x |
- #' @export+ .stats = .stats, |
||
| 186 | -+ | |||
| 163 | +1x |
- h_tab_rsp_one_biomarker <- function(df,+ .formats = .formats, |
||
| 187 | -+ | |||
| 164 | +1x |
- vars,+ .labels = .labels, |
||
| 188 | -+ | |||
| 165 | +1x |
- na_str = default_na_str(),+ .indent_mods = .indent_mods |
||
| 189 | +166 |
- .indent_mods = 0L) {
+ ) |
||
| 190 | -8x | +167 | +1x |
- afuns <- a_response_subgroups(na_str = na_str)[vars]+ lyt <- split_rows_by(lyt, var = var) |
| 191 | -8x | +168 | +1x |
- colvars <- d_rsp_subgroups_colvars(+ lyt <- summarize_row_groups(lyt, na_str = na_str) |
| 192 | -8x | +|||
| 169 | +
- vars,+ |
|||
| 193 | -8x | +170 | +1x |
- conf_level = df$conf_level[1],+ analyze( |
| 194 | -8x | +171 | +1x |
- method = df$pval_label[1]+ lyt, |
| 195 | -+ | |||
| 172 | +1x |
- )+ vars = var, |
||
| 196 | -8x | +173 | +1x |
- h_tab_one_biomarker(+ afun = afun, |
| 197 | -8x | +174 | +1x |
- df = df,+ show_labels = show_labels, |
| 198 | -8x | +175 | +1x |
- afuns = afuns,+ table_names = table_names, |
| 199 | -8x | +176 | +1x |
- colvars = colvars,+ na_str = na_str, |
| 200 | -8x | +177 | +1x |
- na_str = na_str,+ nested = nested, |
| 201 | -8x | +178 | +1x |
- .indent_mods = .indent_mods+ extra_args = extra_args |
| 202 | +179 |
) |
||
| 203 | +180 |
}@@ -166843,14 +168032,14 @@ tern coverage - 90.46% |
| 1 |
- #' Count the Number of Patients with Particular Flags+ #' Patient Counts with Abnormal Range Values |
||
| 5 |
- #' The primary analysis variable `.var` denotes the unique patient identifier.+ #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`) |
||
| 6 |
- #'+ #' and additional analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or |
||
| 7 |
- #' @inheritParams argument_convention+ #' `factor`). For each direction specified in `abnormal` (e.g. high or low) count patients in the |
||
| 8 |
- #' @param flag_variables (`character`)\cr a character vector specifying the names of `logical`+ #' numerator and denominator as follows: |
||
| 9 |
- #' variables from analysis dataset used for counting the number of unique identifiers.+ #' * `num` : The number of patients with this abnormality recorded while on treatment. |
||
| 10 |
- #' @param flag_labels (`character`)\cr vector of labels to use for flag variables.+ #' * `denom`: The number of patients with at least one post-baseline assessment. |
||
| 11 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_flags")`
+ #' |
||
| 12 |
- #' to see available statistics for this function.+ #' @inheritParams argument_convention |
||
| 13 |
- #'+ #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to |
||
| 14 |
- #' @seealso [count_patients_with_event]+ #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list, |
||
| 15 |
- #'+ #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
|
||
| 16 |
- #' @name count_patients_with_flags+ #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality |
||
| 17 |
- #' @order 1+ #' from numerator and denominator. |
||
| 18 |
- NULL+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal")`
|
||
| 19 |
-
+ #' to see available statistics for this function. |
||
| 20 |
- #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which+ #' |
||
| 21 |
- #' a particular flag variable is `TRUE`.+ #' @note |
||
| 22 |
- #'+ #' * `count_abnormal()` only works with a single variable containing multiple abnormal levels. |
||
| 23 |
- #' @inheritParams analyze_variables+ #' * `df` should be filtered to include only post-baseline records. |
||
| 24 |
- #' @param .var (`character`)\cr name of the column that contains the unique identifier.+ #' * the denominator includes patients that might have other abnormal levels at baseline, |
||
| 25 |
- #'+ #' and patients with missing baseline. Patients with these abnormalities at |
||
| 26 |
- #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not+ #' baseline can be optionally excluded from numerator and denominator. |
||
| 27 |
- #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to+ #' |
||
| 28 |
- #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is+ #' @name abnormal |
||
| 29 |
- #' the label to use for this variable.+ #' @include formatting_functions.R |
||
| 30 |
- #'+ #' @order 1 |
||
| 31 |
- #' @return+ NULL |
||
| 32 |
- #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular+ |
||
| 33 |
- #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag.+ #' @describeIn abnormal Statistics function which counts patients with abnormal range values |
||
| 34 |
- #'+ #' for a single `abnormal` level. |
||
| 35 |
- #' @examples+ #' |
||
| 36 |
- #' # `s_count_patients_with_flags()`+ #' @return |
||
| 37 |
- #'+ #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients. |
||
| 38 |
- #' s_count_patients_with_flags(+ #' |
||
| 39 |
- #' adae,+ #' @keywords internal |
||
| 40 |
- #' "SUBJID",+ s_count_abnormal <- function(df, |
||
| 41 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ .var, |
||
| 42 |
- #' denom = "N_col",+ abnormal = list(Low = "LOW", High = "HIGH"), |
||
| 43 |
- #' .N_col = 1000+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 44 |
- #' )+ exclude_base_abn = FALSE) {
|
||
| 45 | -+ | 4x |
- #'+ checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE) |
| 46 | -+ | 4x |
- #' @export+ checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]]))) |
| 47 | -+ | 4x |
- s_count_patients_with_flags <- function(df,+ checkmate::assert_factor(df[[.var]]) |
| 48 | -+ | 4x |
- .var,+ checkmate::assert_flag(exclude_base_abn) |
| 49 | -+ | 4x |
- flag_variables,+ assert_df_with_variables(df, c(range = .var, variables)) |
| 50 | -+ | 4x |
- flag_labels = NULL,+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
| 51 | -+ | 4x |
- .N_col, # nolint+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 52 |
- .N_row, # nolint+ |
||
| 53 | -+ | 4x |
- denom = c("n", "N_row", "N_col")) {
+ count_abnormal_single <- function(abn_name, abn) {
|
| 54 | -5x | +
- checkmate::assert_character(flag_variables)+ # Patients in the denominator fulfill: |
|
| 55 | -5x | +
- if (!is.null(flag_labels)) {
+ # - have at least one post-baseline visit |
|
| 56 | -! | +
- checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE)+ # - their baseline must not be abnormal if `exclude_base_abn`. |
|
| 57 | -! | +8x |
- flag_names <- flag_labels+ if (exclude_base_abn) {
|
| 58 | -+ | 4x |
- } else {
+ denom_select <- !(df[[variables$baseline]] %in% abn) |
| 59 | -5x | +
- if (is.null(names(flag_variables))) {
+ } else {
|
|
| 60 | -5x | +4x |
- flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE)+ denom_select <- TRUE |
| 61 |
- } else {
+ } |
||
| 62 | -! | +8x |
- flag_names <- unname(flag_variables)+ denom <- length(unique(df[denom_select, variables$id, drop = TRUE])) |
| 63 | -! | +
- flag_variables <- names(flag_variables)+ |
|
| 64 |
- }+ # Patients in the numerator fulfill: |
||
| 65 |
- }+ # - have at least one post-baseline visit with the required abnormality level |
||
| 66 |
-
+ # - are part of the denominator patients. |
||
| 67 | -5x | +8x |
- checkmate::assert_subset(flag_variables, colnames(df))+ num_select <- (df[[.var]] %in% abn) & denom_select |
| 68 | -5x | +8x |
- temp <- sapply(flag_variables, function(x) {
+ num <- length(unique(df[num_select, variables$id, drop = TRUE])) |
| 69 | -11x | +
- tmp <- Map(function(y) which(df[[y]]), x)+ |
|
| 70 | -11x | +8x |
- position_satisfy_flags <- Reduce(intersect, tmp)+ formatters::with_label(c(num = num, denom = denom), abn_name) |
| 71 | -11x | +
- id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))+ } |
|
| 72 | -11x | +
- s_count_values(+ |
|
| 73 | -11x | +
- as.character(unique(df[[.var]])),+ # This will define the abnormal levels theoretically possible for a specific lab parameter |
|
| 74 | -11x | +
- id_satisfy_flags,+ # within a split level of a layout. |
|
| 75 | -11x | +4x |
- denom = denom,+ abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]])) |
| 76 | -11x | +4x |
- .N_col = .N_col,+ abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))] |
| 77 | -11x | +
- .N_row = .N_row+ |
|
| 78 | -+ | 4x |
- )+ result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE) |
| 79 | -+ | 4x |
- })+ result <- list(fraction = result) |
| 80 | -5x | +4x |
- colnames(temp) <- flag_names+ result |
| 81 | -5x | +
- temp <- data.frame(t(temp))+ } |
|
| 82 | -5x | +
- result <- temp %>% as.list()+ |
|
| 83 | -5x | +
- if (length(flag_variables) == 1) {
+ #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`. |
|
| 84 | -1x | +
- for (i in 1:3) names(result[[i]]) <- flag_names[1]+ #' |
|
| 85 |
- }+ #' @return |
||
| 86 | -5x | +
- result+ #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 87 |
- }+ #' |
||
| 88 |
-
+ #' @keywords internal |
||
| 89 |
- #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun`+ a_count_abnormal <- make_afun( |
||
| 90 |
- #' in `count_patients_with_flags()`.+ s_count_abnormal, |
||
| 91 |
- #'+ .formats = c(fraction = format_fraction) |
||
| 92 |
- #' @return+ ) |
||
| 93 |
- #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()].+ |
||
| 94 |
- #'+ #' @describeIn abnormal Layout-creating function which can take statistics function arguments |
||
| 95 |
- #' @examples+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 96 |
- #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ #' |
||
| 97 |
- #' # function `format_count_fraction()` can be applied correctly.+ #' @return |
||
| 98 |
- #'+ #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions, |
||
| 99 |
- #' # `a_count_patients_with_flags()`+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 100 |
- #'+ #' the statistics from `s_count_abnormal()` to the table layout. |
||
| 101 |
- #' afun <- make_afun(a_count_patients_with_flags,+ #' |
||
| 102 |
- #' .stats = "count_fraction",+ #' @examples |
||
| 103 |
- #' .ungroup_stats = "count_fraction"+ #' library(dplyr) |
||
| 104 |
- #' )+ #' |
||
| 105 |
- #' afun(+ #' df <- data.frame( |
||
| 106 |
- #' adae,+ #' USUBJID = as.character(c(1, 1, 2, 2)), |
||
| 107 |
- #' .N_col = 10L,+ #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 108 |
- #' .N_row = 10L,+ #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 109 |
- #' .var = "USUBJID",+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 110 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
+ #' stringsAsFactors = FALSE |
||
| 113 |
- #' @export+ #' # Select only post-baseline records. |
||
| 114 |
- a_count_patients_with_flags <- make_afun(+ #' df <- df %>% |
||
| 115 |
- s_count_patients_with_flags,+ #' filter(ONTRTFL == "Y") |
||
| 116 |
- .formats = c("count_fraction" = format_count_fraction_fixed_dp)
+ #' |
||
| 117 |
- )+ #' # Layout creating function. |
||
| 118 |
-
+ #' basic_table() %>% |
||
| 119 |
- #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function+ #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>% |
||
| 120 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' build_table(df) |
||
| 122 |
- #' @return+ #' # Passing of statistics function and formatting arguments. |
||
| 123 |
- #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions,+ #' df2 <- data.frame( |
||
| 124 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' ID = as.character(c(1, 1, 2, 2)), |
||
| 125 |
- #' the statistics from `s_count_patients_with_flags()` to the table layout.+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 126 |
- #'+ #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 127 |
- #' @examples+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 128 |
- #' library(dplyr)+ #' stringsAsFactors = FALSE |
||
| 129 |
- #'+ #' ) |
||
| 130 |
- #' # Add labelled flag variables to analysis dataset.+ #' |
||
| 131 |
- #' adae <- tern_ex_adae %>%+ #' # Select only post-baseline records. |
||
| 132 |
- #' mutate(+ #' df2 <- df2 %>% |
||
| 133 |
- #' fl1 = TRUE %>% with_label("Total AEs"),
+ #' filter(ONTRTFL == "Y") |
||
| 134 |
- #' fl2 = (TRTEMFL == "Y") %>%+ #' |
||
| 135 |
- #' with_label("Total number of patients with at least one adverse event"),
+ #' basic_table() %>% |
||
| 136 |
- #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>%+ #' count_abnormal( |
||
| 137 |
- #' with_label("Total number of patients with fatal AEs"),
+ #' var = "RANGE", |
||
| 138 |
- #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>%+ #' abnormal = list(low = "LOW", high = "HIGH"), |
||
| 139 |
- #' with_label("Total number of patients with related fatal AEs")
+ #' variables = list(id = "ID", baseline = "BL_RANGE") |
||
| 140 |
- #' )+ #' ) %>% |
||
| 141 |
- #'+ #' build_table(df2) |
||
| 142 |
- #' # `count_patients_with_flags()`+ #' |
||
| 143 |
- #'+ #' @export |
||
| 144 |
- #' lyt2 <- basic_table() %>%+ #' @order 2 |
||
| 145 |
- #' split_cols_by("ARM") %>%
+ count_abnormal <- function(lyt, |
||
| 146 |
- #' add_colcounts() %>%+ var, |
||
| 147 |
- #' count_patients_with_flags(+ abnormal = list(Low = "LOW", High = "HIGH"), |
||
| 148 |
- #' "SUBJID",+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 149 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ exclude_base_abn = FALSE, |
||
| 150 |
- #' denom = "N_col"+ na_str = default_na_str(), |
||
| 151 |
- #' )+ nested = TRUE, |
||
| 152 |
- #'+ ..., |
||
| 153 |
- #' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl)+ table_names = var, |
||
| 154 |
- #'+ .stats = NULL, |
||
| 155 |
- #' @export+ .formats = NULL, |
||
| 156 |
- #' @order 2+ .labels = NULL, |
||
| 157 |
- count_patients_with_flags <- function(lyt,+ .indent_mods = NULL) {
|
||
| 158 | -+ | 3x |
- var,+ extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...) |
| 159 |
- flag_variables,+ |
||
| 160 | -+ | 3x |
- flag_labels = NULL,+ afun <- make_afun( |
| 161 | -+ | 3x |
- var_labels = var,+ a_count_abnormal, |
| 162 | -+ | 3x |
- show_labels = "hidden",+ .stats = .stats, |
| 163 | -+ | 3x |
- riskdiff = FALSE,+ .formats = .formats, |
| 164 | -+ | 3x |
- na_str = default_na_str(),+ .labels = .labels, |
| 165 | -+ | 3x |
- nested = TRUE,+ .indent_mods = .indent_mods, |
| 166 | -+ | 3x |
- ...,+ .ungroup_stats = "fraction" |
| 167 |
- table_names = paste0("tbl_flags_", var),
+ ) |
||
| 168 |
- .stats = "count_fraction",+ |
||
| 169 | -+ | 3x |
- .formats = NULL,+ checkmate::assert_string(var) |
| 170 |
- .indent_mods = NULL) {
+
|
||
| 171 | -6x | +3x |
- checkmate::assert_flag(riskdiff)+ analyze( |
| 172 | -+ | 3x |
-
+ lyt = lyt, |
| 173 | -6x | +3x |
- s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...)+ vars = var, |
| 174 | -+ | 3x |
-
+ afun = afun, |
| 175 | -6x | +3x |
- afun <- make_afun(+ na_str = na_str, |
| 176 | -6x | +3x |
- a_count_patients_with_flags,+ nested = nested, |
| 177 | -6x | +3x |
- .stats = .stats,+ table_names = table_names, |
| 178 | -6x | +3x |
- .formats = .formats,+ extra_args = extra_args, |
| 179 | -6x | -
- .indent_mods = .indent_mods,- |
- |
| 180 | -6x | -
- .ungroup_stats = .stats- |
- |
| 181 | -- |
- )- |
- |
| 182 | -- | - - | -|
| 183 | -6x | -
- extra_args <- if (isFALSE(riskdiff)) {
- |
- |
| 184 | -5x | -
- s_args- |
- |
| 185 | -- |
- } else {
- |
- |
| 186 | -1x | -
- list(- |
- |
| 187 | -1x | -
- afun = list("s_count_patients_with_flags" = afun),
- |
- |
| 188 | -1x | -
- .stats = .stats,- |
- |
| 189 | -1x | -
- .indent_mods = .indent_mods,- |
- |
| 190 | -1x | -
- s_args = s_args- |
- |
| 191 | -- |
- )- |
- |
| 192 | -- |
- }- |
- |
| 193 | -- | - - | -|
| 194 | -6x | -
- lyt <- analyze(- |
- |
| 195 | -6x | -
- lyt = lyt,- |
- |
| 196 | -6x | -
- vars = var,- |
- |
| 197 | -6x | -
- var_labels = var_labels,- |
- |
| 198 | -6x | -
- show_labels = show_labels,- |
- |
| 199 | -6x | -
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),- |
- |
| 200 | -6x | -
- table_names = table_names,- |
- |
| 201 | -6x | -
- na_str = na_str,- |
- |
| 202 | -6x | -
- nested = nested,- |
- |
| 203 | -6x | +3x |
- extra_args = extra_args+ show_labels = "hidden" |
| 204 | +180 |
) |
|
| 205 | -- | - - | -|
| 206 | -6x | -
- lyt- |
- |
| 207 | +181 |
}@@ -168298,14 +169305,14 @@ tern coverage - 90.46% |
| 1 |
- #' Estimation of Proportions per Level of Factor+ #' Counting Specific Values |
|||
| 5 |
- #' Estimate the proportion along with confidence interval of a proportion+ #' We can count the occurrence of specific values in a variable of interest. |
|||
| 6 |
- #' regarding the level of a factor.+ #' |
|||
| 7 |
- #'+ #' @inheritParams argument_convention |
|||
| 8 |
- #' @inheritParams argument_convention+ #' @param values (`character`)\cr specific values that should be counted. |
|||
| 9 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_multinomial_response")`
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_values")`
|
|||
| 12 |
- #' @seealso Relevant description function [d_onco_rsp_label()].+ #' @note |
|||
| 13 |
- #'+ #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x` |
|||
| 14 |
- #' @name estimate_multinomial_rsp+ #' and fails otherwise. |
|||
| 15 |
- #' @order 1+ #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`, |
|||
| 16 |
- NULL+ #' otherwise they are hidden. |
|||
| 17 |
-
+ #' |
|||
| 18 |
- #' Description of Standard Oncology Response+ #' @name count_values_funs |
|||
| 19 |
- #'+ #' @order 1 |
|||
| 20 |
- #' @description `r lifecycle::badge("stable")`
+ NULL |
|||
| 21 |
- #'+ |
|||
| 22 |
- #' Describe the oncology response in a standard way.+ #' @describeIn count_values_funs S3 generic function to count values. |
|||
| 24 |
- #' @param x (`character`)\cr the standard oncology code to be described.+ #' @inheritParams s_summary.logical |
|||
| 26 |
- #' @return Response labels.+ #' @return |
|||
| 27 |
- #'+ #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable. |
|||
| 28 |
- #' @seealso [estimate_multinomial_rsp()]+ #' |
|||
| 29 |
- #'+ #' @export |
|||
| 30 |
- #' @examples+ s_count_values <- function(x, |
|||
| 31 |
- #' d_onco_rsp_label(+ values, |
|||
| 32 |
- #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
+ na.rm = TRUE, # nolint |
|||
| 33 |
- #' )+ .N_col, # nolint |
|||
| 34 |
- #'+ .N_row, # nolint |
|||
| 35 |
- #' # Adding some values not considered in d_onco_rsp_label+ denom = c("n", "N_row", "N_col")) {
|
|||
| 36 | -+ | 110x |
- #'+ UseMethod("s_count_values", x)
|
|
| 37 |
- #' d_onco_rsp_label(+ } |
|||
| 38 |
- #' c("CR", "PR", "hello", "hi")
+
|
|||
| 39 |
- #' )+ #' @describeIn count_values_funs Method for `character` class. |
|||
| 41 |
- #' @export+ #' @method s_count_values character |
|||
| 42 |
- d_onco_rsp_label <- function(x) {
+ #' |
|||
| 43 | -2x | +
- x <- as.character(x)+ #' @examples |
||
| 44 | -2x | +
- desc <- c(+ #' # `s_count_values.character` |
||
| 45 | -2x | +
- CR = "Complete Response (CR)",+ #' s_count_values(x = c("a", "b", "a"), values = "a")
|
||
| 46 | -2x | +
- PR = "Partial Response (PR)",+ #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
|
||
| 47 | -2x | +
- MR = "Minimal/Minor Response (MR)",+ #' |
||
| 48 | -2x | +
- MRD = "Minimal Residual Disease (MRD)",+ #' @export |
||
| 49 | -2x | +
- SD = "Stable Disease (SD)",+ s_count_values.character <- function(x, |
||
| 50 | -2x | +
- PD = "Progressive Disease (PD)",+ values = "Y", |
||
| 51 | -2x | +
- `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)",+ na.rm = TRUE, # nolint |
||
| 52 | -2x | +
- NE = "Not Evaluable (NE)",+ ...) {
|
||
| 53 | -2x | +108x |
- `NE/Missing` = "Missing or unevaluable",+ checkmate::assert_character(values) |
|
| 54 | -2x | +
- Missing = "Missing",+ |
||
| 55 | -2x | +108x |
- `NA` = "Not Applicable (NA)",+ if (na.rm) {
|
|
| 56 | -2x | +108x |
- ND = "Not Done (ND)"+ x <- x[!is.na(x)] |
|
| 57 |
- )+ } |
|||
| 59 | -2x | +108x |
- values_label <- vapply(+ is_in_values <- x %in% values |
|
| 60 | -2x | +
- X = x,+ |
||
| 61 | -2x | +108x |
- FUN.VALUE = character(1),+ s_summary(is_in_values, ...) |
|
| 62 | -2x | +
- function(val) {
+ } |
||
| 63 | -! | +
- if (val %in% names(desc)) desc[val] else val+ |
||
| 64 |
- }+ #' @describeIn count_values_funs Method for `factor` class. This makes an automatic |
|||
| 65 |
- )+ #' conversion to `character` and then forwards to the method for characters. |
|||
| 66 |
-
+ #' |
|||
| 67 | -2x | +
- return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc))))+ #' @method s_count_values factor |
||
| 68 |
- }+ #' |
|||
| 69 |
-
+ #' @examples |
|||
| 70 |
- #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number+ #' # `s_count_values.factor` |
|||
| 71 |
- #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()].+ #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
|
|||
| 73 |
- #' @return+ #' @export |
|||
| 74 |
- #' * `s_length_proportion()` returns statistics from [s_proportion()].+ s_count_values.factor <- function(x, |
|||
| 75 |
- #'+ values = "Y", |
|||
| 76 |
- #' @examples+ ...) {
|
|||
| 77 | -+ | 3x |
- #' s_length_proportion(rep("CR", 10), .N_col = 100)
+ s_count_values(as.character(x), values = as.character(values), ...) |
|
| 78 |
- #' s_length_proportion(factor(character(0)), .N_col = 100)+ } |
|||
| 79 |
- #'+ |
|||
| 80 |
- #' @export+ #' @describeIn count_values_funs Method for `logical` class. |
|||
| 81 |
- s_length_proportion <- function(x,+ #' |
|||
| 82 |
- .N_col, # nolint+ #' @method s_count_values logical |
|||
| 83 |
- ...) {
+ #' |
|||
| 84 | -4x | +
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ #' @examples |
||
| 85 | -3x | +
- checkmate::assert_vector(x, min.len = 0, max.len = .N_col)+ #' # `s_count_values.logical` |
||
| 86 | -2x | +
- checkmate::assert_vector(unique(x), min.len = 0, max.len = 1)+ #' s_count_values(x = c(TRUE, FALSE, TRUE)) |
||
| 87 |
-
+ #' |
|||
| 88 | -1x | +
- n_true <- length(x)+ #' @export |
||
| 89 | -1x | +
- n_false <- .N_col - n_true+ s_count_values.logical <- function(x, values = TRUE, ...) {
|
||
| 90 | -1x | +3x |
- x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false))+ checkmate::assert_logical(values) |
|
| 91 | -1x | +3x |
- s_proportion(df = x_logical, ...)+ s_count_values(as.character(x), values = as.character(values), ...) |
|
| 94 |
- #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun`+ #' @describeIn count_values_funs Formatted analysis function which is used as `afun` |
|||
| 95 |
- #' in `estimate_multinomial_response()`.+ #' in `count_values()`. |
|||
| 98 |
- #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 101 |
- #' a_length_proportion(rep("CR", 10), .N_col = 100)
+ #' # `a_count_values` |
|||
| 102 |
- #' a_length_proportion(factor(character(0)), .N_col = 100)+ #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
|
|||
| 105 |
- a_length_proportion <- make_afun(+ a_count_values <- make_afun( |
|||
| 106 |
- s_length_proportion,- |
- |||
| 107 | -- |
- .formats = c(- |
- ||
| 108 | -- |
- n_prop = "xx (xx.x%)",- |
- ||
| 109 | -- |
- prop_ci = "(xx.xx, xx.xx)"- |
- ||
| 110 | -- |
- )- |
- ||
| 111 | -- |
- )- |
- ||
| 112 | -- | - - | -||
| 113 | -- |
- #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments- |
- ||
| 114 | -- |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and- |
- ||
| 115 | -- |
- #' [rtables::summarize_row_groups()].- |
- ||
| 116 | -- |
- #'- |
- ||
| 117 | -- |
- #' @return- |
- ||
| 118 | -- |
- #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions,- |
- ||
| 119 | -- |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing- |
- ||
| 120 | -- |
- #' the statistics from `s_length_proportion()` to the table layout.- |
- ||
| 121 | -- |
- #'- |
- ||
| 122 | -- |
- #' @examples- |
- ||
| 123 | -- |
- #' library(dplyr)- |
- ||
| 124 | -- |
- #'- |
- ||
| 125 | -- |
- #' # Use of the layout creating function.- |
- ||
| 126 | -- |
- #' dta_test <- data.frame(- |
- ||
| 127 | -- |
- #' USUBJID = paste0("S", 1:12),
+ s_count_values, |
||
| 128 | +107 |
- #' ARM = factor(rep(LETTERS[1:3], each = 4)),+ .formats = c(count_fraction = "xx (xx.xx%)", count = "xx") |
||
| 129 | +108 |
- #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ ) |
||
| 130 | +109 |
- #' ) %>% mutate(+ |
||
| 131 | +110 |
- #' AVALC = factor(AVAL,+ #' @describeIn count_values_funs Layout-creating function which can take statistics function arguments |
||
| 132 | +111 |
- #' levels = c(0, 1),+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 133 | +112 |
- #' labels = c("Complete Response (CR)", "Partial Response (PR)")
+ #' |
||
| 134 | +113 |
- #' )+ #' @return |
||
| 135 | +114 |
- #' )+ #' * `count_values()` returns a layout object suitable for passing to further layouting functions, |
||
| 136 | +115 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 137 | +116 |
- #' lyt <- basic_table() %>%+ #' the statistics from `s_count_values()` to the table layout. |
||
| 138 | +117 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 139 | +118 |
- #' estimate_multinomial_response(var = "AVALC")+ #' @examples |
||
| 140 | +119 |
- #'+ #' # `count_values` |
||
| 141 | +120 |
- #' tbl <- build_table(lyt, dta_test)+ #' basic_table() %>% |
||
| 142 | +121 |
- #'+ #' count_values("Species", values = "setosa") %>%
|
||
| 143 | +122 |
- #' tbl+ #' build_table(iris) |
||
| 144 | +123 |
#' |
||
| 145 | +124 |
#' @export |
||
| 146 | +125 |
#' @order 2 |
||
| 147 | +126 |
- estimate_multinomial_response <- function(lyt,+ count_values <- function(lyt, |
||
| 148 | +127 |
- var,+ vars, |
||
| 149 | +128 |
- na_str = default_na_str(),+ values, |
||
| 150 | +129 |
- nested = TRUE,+ na_str = default_na_str(), |
||
| 151 | +130 |
- ...,+ nested = TRUE, |
||
| 152 | +131 |
- show_labels = "hidden",+ ..., |
||
| 153 | +132 |
- table_names = var,+ table_names = vars, |
||
| 154 | +133 |
- .stats = "prop_ci",+ .stats = "count_fraction", |
||
| 155 | +134 |
- .formats = NULL,+ .formats = NULL, |
||
| 156 | +135 |
- .labels = NULL,+ .labels = c(count_fraction = paste(values, collapse = ", ")), |
||
| 157 | +136 |
- .indent_mods = NULL) {
+ .indent_mods = NULL) {
|
||
| 158 | -1x | +137 | +3x |
- extra_args <- list(...)+ extra_args <- list(values = values, ...) |
| 159 | +138 | |||
| 160 | -1x | +139 | +3x |
afun <- make_afun( |
| 161 | -1x | +140 | +3x |
- a_length_proportion,+ a_count_values, |
| 162 | -1x | +141 | +3x |
.stats = .stats, |
| 163 | -1x | +142 | +3x |
.formats = .formats, |
| 164 | -1x | +143 | +3x |
.labels = .labels, |
| 165 | -1x | +144 | +3x |
.indent_mods = .indent_mods |
| 166 | +145 |
) |
||
| 167 | -1x | -
- lyt <- split_rows_by(lyt, var = var)- |
- ||
| 168 | -1x | -
- lyt <- summarize_row_groups(lyt, na_str = na_str)- |
- ||
| 169 | -- | - - | -||
| 170 | -1x | +146 | +3x |
analyze( |
| 171 | -1x | +147 | +3x |
lyt, |
| 172 | -1x | +148 | +3x |
- vars = var,+ vars, |
| 173 | -1x | +149 | +3x |
afun = afun, |
| 174 | -1x | +150 | +3x |
- show_labels = show_labels,+ na_str = na_str, |
| 175 | -1x | +151 | +3x |
- table_names = table_names,+ nested = nested, |
| 176 | -1x | +152 | +3x |
- na_str = na_str,+ extra_args = extra_args, |
| 177 | -1x | +153 | +3x |
- nested = nested,+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 178 | -1x | +154 | +3x |
- extra_args = extra_args+ table_names = table_names |
| 179 | +155 |
) |
||
| 180 | +156 |
}@@ -169564,14 +170403,14 @@ tern coverage - 90.46% |
| 1 |
- #' Apply 1/3 or 1/2 Imputation Rule to Data+ #' Subgroup Treatment Effect Pattern (STEP) Fit for Survival Outcome |
||
| 5 |
- #' @inheritParams argument_convention+ #' This fits the Subgroup Treatment Effect Pattern models for a survival outcome. The treatment arm |
||
| 6 |
- #' @param x_stats (`named list`)\cr a named list of statistics, typically the results of [s_summary()].+ #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated |
||
| 7 |
- #' @param stat (`character`)\cr statistic to return the value/NA level of according to the imputation+ #' hazard ratios are for the comparison of the second level vs. the first one. |
||
| 8 |
- #' rule applied.+ #' |
||
| 9 |
- #' @param imp_rule (`character`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation+ #' The model which is fit is: |
||
| 10 |
- #' rule or `"1/2"` to implement 1/2 imputation rule.+ #' |
||
| 11 |
- #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`).+ #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
||
| 12 |
- #' This parameter is only used when `imp_rule` is set to `"1/3"`.+ #' |
||
| 13 |
- #' @param avalcat_var (`character`)\cr name of variable that indicates whether a row in `df` corresponds+ #' where `degree` is specified by `control_step()`. |
||
| 14 |
- #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above+ #' |
||
| 15 |
- #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`.+ #' @inheritParams argument_convention |
||
| 16 |
- #'+ #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`, |
||
| 17 |
- #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed+ #' `arm`, `biomarker`, and optional `covariates` and `strata`. |
||
| 18 |
- #' according to the specified imputation rule.+ #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()]. |
||
| 20 |
- #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule`+ #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used |
||
| 21 |
- #' argument.+ #' for the biomarker variable, including where the center of the intervals are and their bounds. The |
||
| 22 |
- #'+ #' second part of the columns contain the estimates for the treatment arm comparison. |
||
| 23 |
- #' @examples+ #' |
||
| 24 |
- #' set.seed(1)+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
||
| 25 |
- #' df <- data.frame(+ #' |
||
| 26 |
- #' AVAL = runif(50, 0, 1),+ #' @seealso [control_step()] and [control_coxph()] for the available customization options. |
||
| 27 |
- #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE)+ #' |
||
| 28 |
- #' )+ #' @examples |
||
| 29 |
- #' x_stats <- s_summary(df$AVAL)+ #' # Testing dataset with just two treatment arms. |
||
| 30 |
- #' imputation_rule(df, x_stats, "max", "1/3")+ #' library(dplyr) |
||
| 31 |
- #' imputation_rule(df, x_stats, "geom_mean", "1/3")+ #' |
||
| 32 |
- #' imputation_rule(df, x_stats, "mean", "1/2")+ #' adtte_f <- tern_ex_adtte %>% |
||
| 33 |
- #'+ #' filter( |
||
| 34 |
- #' @export+ #' PARAMCD == "OS", |
||
| 35 |
- imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 36 | -42x | +
- checkmate::assert_choice(avalcat_var, names(df))+ #' ) %>% |
|
| 37 | -42x | +
- checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
+ #' mutate( |
|
| 38 | -42x | +
- n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
|
| 39 | -42x | +
- ltr_blq_ratio <- n_blq / max(1, nrow(df))+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
|
| 40 |
-
+ #' is_event = CNSR == 0 |
||
| 41 |
- # defaults+ #' ) |
||
| 42 | -42x | +
- val <- x_stats[[stat]]+ #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
|
|
| 43 | -42x | +
- na_str <- "NE"+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|
| 44 |
-
+ #' |
||
| 45 | -42x | +
- if (imp_rule == "1/3") {
+ #' variables <- list( |
|
| 46 | -1x | +
- if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT+ #' arm = "ARM", |
|
| 47 | -41x | +
- if (ltr_blq_ratio > 1 / 3) {
+ #' biomarker = "BMRKR1", |
|
| 48 | -29x | +
- if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT+ #' covariates = c("AGE", "BMRKR2"),
|
|
| 49 | -4x | +
- if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
+ #' event = "is_event", |
|
| 50 | -18x | +
- if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
+ #' time = "AVAL" |
|
| 51 |
- }+ #' ) |
||
| 52 | -1x | +
- } else if (imp_rule == "1/2") {
+ #' |
|
| 53 | -1x | +
- if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
|
| 54 | -! | +
- val <- NA # 1/2_GT+ #' step_matrix <- fit_survival_step( |
|
| 55 | -! | +
- na_str <- "ND" # 1/2_GT+ #' variables = variables, |
|
| 56 |
- }+ #' data = adtte_f |
||
| 57 |
- }+ #' ) |
||
| 58 |
-
+ #' dim(step_matrix) |
||
| 59 | -42x | +
- list(val = val, na_str = na_str)+ #' head(step_matrix) |
|
| 60 |
- }+ #' |
| 1 | +61 |
- #' Patient Counts with Abnormal Range Values+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
|
| 2 | +62 |
- #'+ #' # models. Or specify different Cox regression options. |
|
| 3 | +63 |
- #' @description `r lifecycle::badge("stable")`
+ #' step_matrix2 <- fit_survival_step( |
|
| 4 | +64 |
- #'+ #' variables = variables, |
|
| 5 | +65 |
- #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`)+ #' data = adtte_f, |
|
| 6 | +66 |
- #' and additional analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or+ #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2)) |
|
| 7 | +67 |
- #' `factor`). For each direction specified in `abnormal` (e.g. high or low) count patients in the+ #' ) |
|
| 8 | +68 |
- #' numerator and denominator as follows:+ #' |
|
| 9 | +69 |
- #' * `num` : The number of patients with this abnormality recorded while on treatment.+ #' # Use a global model with cubic interaction and only 5 points. |
|
| 10 | +70 |
- #' * `denom`: The number of patients with at least one post-baseline assessment.+ #' step_matrix3 <- fit_survival_step( |
|
| 11 | +71 |
- #'+ #' variables = variables, |
|
| 12 | +72 |
- #' @inheritParams argument_convention+ #' data = adtte_f, |
|
| 13 | +73 |
- #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to+ #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L)) |
|
| 14 | +74 |
- #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list,+ #' ) |
|
| 15 | +75 |
- #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
+ #' |
|
| 16 | +76 |
- #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality+ #' @export |
|
| 17 | +77 |
- #' from numerator and denominator.+ fit_survival_step <- function(variables, |
|
| 18 | +78 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal")`
+ data, |
|
| 19 | +79 |
- #' to see available statistics for this function.+ control = c(control_step(), control_coxph())) {
|
|
| 20 | -+ | ||
| 80 | +4x |
- #'+ checkmate::assert_list(control) |
|
| 21 | -+ | ||
| 81 | +4x |
- #' @note+ assert_df_with_variables(data, variables) |
|
| 22 | -+ | ||
| 82 | +4x |
- #' * `count_abnormal()` only works with a single variable containing multiple abnormal levels.+ data <- data[!is.na(data[[variables$biomarker]]), ] |
|
| 23 | -+ | ||
| 83 | +4x |
- #' * `df` should be filtered to include only post-baseline records.+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
|
| 24 | -+ | ||
| 84 | +4x |
- #' * the denominator includes patients that might have other abnormal levels at baseline,+ interval_center <- window_sel$interval[, "Interval Center"] |
|
| 25 | -+ | ||
| 85 | +4x |
- #' and patients with missing baseline. Patients with these abnormalities at+ form <- h_step_survival_formula(variables = variables, control = control) |
|
| 26 | -+ | ||
| 86 | +4x |
- #' baseline can be optionally excluded from numerator and denominator.+ estimates <- if (is.null(control$bandwidth)) {
|
|
| 27 | -+ | ||
| 87 | +1x |
- #'+ h_step_survival_est( |
|
| 28 | -+ | ||
| 88 | +1x |
- #' @name abnormal+ formula = form, |
|
| 29 | -+ | ||
| 89 | +1x |
- #' @include formatting_functions.R+ data = data, |
|
| 30 | -+ | ||
| 90 | +1x |
- #' @order 1+ variables = variables, |
|
| 31 | -+ | ||
| 91 | +1x |
- NULL+ x = interval_center, |
|
| 32 | -+ | ||
| 92 | +1x |
-
+ control = control |
|
| 33 | +93 |
- #' @describeIn abnormal Statistics function which counts patients with abnormal range values+ ) |
|
| 34 | +94 |
- #' for a single `abnormal` level.+ } else {
|
|
| 35 | -+ | ||
| 95 | +3x |
- #'+ tmp <- mapply( |
|
| 36 | -+ | ||
| 96 | +3x |
- #' @return+ FUN = h_step_survival_est, |
|
| 37 | -+ | ||
| 97 | +3x |
- #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients.+ x = interval_center, |
|
| 38 | -+ | ||
| 98 | +3x |
- #'+ subset = as.list(as.data.frame(window_sel$sel)), |
|
| 39 | -+ | ||
| 99 | +3x |
- #' @keywords internal+ MoreArgs = list( |
|
| 40 | -+ | ||
| 100 | +3x |
- s_count_abnormal <- function(df,+ formula = form,+ |
+ |
| 101 | +3x | +
+ data = data,+ |
+ |
| 102 | +3x | +
+ variables = variables,+ |
+ |
| 103 | +3x | +
+ control = control |
|
| 41 | +104 |
- .var,+ ) |
|
| 42 | +105 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ ) |
|
| 43 | +106 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ # Maybe we find a more elegant solution than this.+ |
+ |
| 107 | +3x | +
+ rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
+ |
+ |
| 108 | +3x | +
+ t(tmp) |
|
| 44 | +109 |
- exclude_base_abn = FALSE) {
+ } |
|
| 45 | +110 | 4x |
- checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE)+ result <- cbind(window_sel$interval, estimates) |
| 46 | +111 | 4x |
- checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]])))+ structure( |
| 47 | +112 | 4x |
- checkmate::assert_factor(df[[.var]])+ result, |
| 48 | +113 | 4x |
- checkmate::assert_flag(exclude_base_abn)+ class = c("step", "matrix"),
|
| 49 | +114 | 4x |
- assert_df_with_variables(df, c(range = .var, variables))+ variables = variables, |
| 50 | +115 | 4x |
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ control = control |
| 51 | -4x | +||
| 116 | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ ) |
||
| 52 | +117 |
-
+ } |
|
| 53 | -4x | +
| 1 | +
- count_abnormal_single <- function(abn_name, abn) {
+ #' Counting Missed Doses |
|||
| 54 | +2 |
- # Patients in the denominator fulfill:+ #' |
||
| 55 | +3 |
- # - have at least one post-baseline visit+ #' @description `r lifecycle::badge("stable")`
|
||
| 56 | +4 |
- # - their baseline must not be abnormal if `exclude_base_abn`.+ #' |
||
| 57 | -8x | +|||
| 5 | +
- if (exclude_base_abn) {
+ #' These are specific functions to count patients with missed doses. The difference to [count_cumulative()] is |
|||
| 58 | -4x | +|||
| 6 | +
- denom_select <- !(df[[variables$baseline]] %in% abn)+ #' mainly the special labels. |
|||
| 59 | +7 |
- } else {
+ #' |
||
| 60 | -4x | +|||
| 8 | +
- denom_select <- TRUE+ #' @inheritParams s_count_cumulative |
|||
| 61 | +9 |
- }+ #' @inheritParams argument_convention |
||
| 62 | -8x | +|||
| 10 | +
- denom <- length(unique(df[denom_select, variables$id, drop = TRUE]))+ #' @param thresholds (vector of `count`)\cr number of missed doses the patients at least had. |
|||
| 63 | +11 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_missed_doses")`
|
||
| 64 | +12 |
- # Patients in the numerator fulfill:+ #' to see available statistics for this function. |
||
| 65 | +13 |
- # - have at least one post-baseline visit with the required abnormality level+ #' |
||
| 66 | +14 |
- # - are part of the denominator patients.+ #' @seealso Relevant description function [d_count_missed_doses()]. |
||
| 67 | -8x | +|||
| 15 | +
- num_select <- (df[[.var]] %in% abn) & denom_select+ #' |
|||
| 68 | -8x | +|||
| 16 | +
- num <- length(unique(df[num_select, variables$id, drop = TRUE]))+ #' @name count_missed_doses |
|||
| 69 | +17 | ++ |
+ #' @order 1+ |
+ |
| 18 | ++ |
+ NULL+ |
+ ||
| 19 | ||||
| 70 | -8x | +|||
| 20 | +
- formatters::with_label(c(num = num, denom = denom), abn_name)+ #' @describeIn count_missed_doses Statistics function to count non-missing values. |
|||
| 71 | +21 |
- }+ #' |
||
| 72 | +22 |
-
+ #' @return |
||
| 73 | +23 |
- # This will define the abnormal levels theoretically possible for a specific lab parameter+ #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`. |
||
| 74 | +24 |
- # within a split level of a layout.+ #' |
||
| 75 | -4x | +|||
| 25 | +
- abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]]))+ #' @keywords internal+ |
+ |||
| 26 | ++ |
+ s_count_nonmissing <- function(x) {
|
||
| 76 | -4x | +27 | +5x |
- abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))]+ list(n = n_available(x)) |
| 77 | +28 | ++ |
+ }+ |
+ |
| 29 | ||||
| 78 | -4x | +|||
| 30 | +
- result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE)+ #' Description Function that Calculates Labels for [s_count_missed_doses()]. |
|||
| 79 | -4x | +|||
| 31 | +
- result <- list(fraction = result)+ #'+ |
+ |||
| 32 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ ||
| 33 | ++ |
+ #'+ |
+ ||
| 34 | ++ |
+ #' @inheritParams s_count_missed_doses+ |
+ ||
| 35 | ++ |
+ #'+ |
+ ||
| 36 | ++ |
+ #' @return [d_count_missed_doses()] returns a named `character` vector with the labels.+ |
+ ||
| 37 | ++ |
+ #'+ |
+ ||
| 38 | ++ |
+ #' @seealso [s_count_missed_doses()]+ |
+ ||
| 39 | ++ |
+ #'+ |
+ ||
| 40 | ++ |
+ #' @export+ |
+ ||
| 41 | ++ |
+ d_count_missed_doses <- function(thresholds) {
|
||
| 80 | +42 | 4x |
- result+ paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
|
|
| 81 | +43 |
} |
||
| 82 | +44 | |||
| 83 | +45 |
- #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`.+ #' @describeIn count_missed_doses Statistics function to count patients with missed doses. |
||
| 84 | +46 |
#' |
||
| 85 | +47 |
#' @return |
||
| 86 | +48 |
- #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold. |
||
| 87 | +49 |
#' |
||
| 88 | +50 |
#' @keywords internal |
||
| 89 | +51 |
- a_count_abnormal <- make_afun(+ s_count_missed_doses <- function(x,+ |
+ ||
| 52 | ++ |
+ thresholds, |
||
| 90 | +53 |
- s_count_abnormal,+ .N_col) { # nolint
|
||
| 91 | -+ | |||
| 54 | +1x |
- .formats = c(fraction = format_fraction)+ stat <- s_count_cumulative( |
||
| 92 | -+ | |||
| 55 | +1x |
- )+ x = x, |
||
| 93 | -+ | |||
| 56 | +1x |
-
+ thresholds = thresholds, |
||
| 94 | -+ | |||
| 57 | +1x |
- #' @describeIn abnormal Layout-creating function which can take statistics function arguments+ lower_tail = FALSE, |
||
| 95 | -+ | |||
| 58 | +1x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ include_eq = TRUE, |
||
| 96 | -+ | |||
| 59 | +1x |
- #'+ .N_col = .N_col |
||
| 97 | +60 |
- #' @return+ ) |
||
| 98 | -+ | |||
| 61 | +1x |
- #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions,+ labels <- d_count_missed_doses(thresholds) |
||
| 99 | -+ | |||
| 62 | +1x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ for (i in seq_along(stat$count_fraction)) {
|
||
| 100 | -+ | |||
| 63 | +2x |
- #' the statistics from `s_count_abnormal()` to the table layout.+ stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i]) |
||
| 101 | +64 |
- #'+ } |
||
| 102 | -+ | |||
| 65 | +1x |
- #' @examples+ n_stat <- s_count_nonmissing(x)+ |
+ ||
| 66 | +1x | +
+ c(n_stat, stat) |
||
| 103 | +67 |
- #' library(dplyr)+ } |
||
| 104 | +68 |
- #'+ |
||
| 105 | +69 |
- #' df <- data.frame(+ #' @describeIn count_missed_doses Formatted analysis function which is used as `afun` |
||
| 106 | +70 |
- #' USUBJID = as.character(c(1, 1, 2, 2)),+ #' in `count_missed_doses()`. |
||
| 107 | +71 |
- #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' |
||
| 108 | +72 |
- #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ #' @return |
||
| 109 | +73 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 110 | +74 |
- #' stringsAsFactors = FALSE+ #' |
||
| 111 | +75 |
- #' )+ #' @keywords internal |
||
| 112 | +76 |
- #'+ a_count_missed_doses <- make_afun( |
||
| 113 | +77 |
- #' # Select only post-baseline records.+ s_count_missed_doses, |
||
| 114 | +78 |
- #' df <- df %>%+ .formats = c(n = "xx", count_fraction = format_count_fraction) |
||
| 115 | +79 |
- #' filter(ONTRTFL == "Y")+ ) |
||
| 116 | +80 |
- #'+ |
||
| 117 | +81 |
- #' # Layout creating function.+ #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments |
||
| 118 | +82 |
- #' basic_table() %>%+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 119 | +83 |
- #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>%+ #' |
||
| 120 | +84 |
- #' build_table(df)+ #' @return |
||
| 121 | +85 |
- #'+ #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions, |
||
| 122 | +86 |
- #' # Passing of statistics function and formatting arguments.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 123 | +87 |
- #' df2 <- data.frame(+ #' the statistics from `s_count_missed_doses()` to the table layout. |
||
| 124 | +88 |
- #' ID = as.character(c(1, 1, 2, 2)),+ #' |
||
| 125 | +89 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' @examples |
||
| 126 | +90 |
- #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ #' library(dplyr) |
||
| 127 | +91 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ #' |
||
| 128 | +92 |
- #' stringsAsFactors = FALSE+ #' anl <- tern_ex_adsl %>% |
||
| 129 | +93 |
- #' )+ #' distinct(STUDYID, USUBJID, ARM) %>% |
||
| 130 | +94 |
- #'+ #' mutate( |
||
| 131 | +95 |
- #' # Select only post-baseline records.+ #' PARAMCD = "TNDOSMIS", |
||
| 132 | +96 |
- #' df2 <- df2 %>%+ #' PARAM = "Total number of missed doses during study", |
||
| 133 | +97 |
- #' filter(ONTRTFL == "Y")+ #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE), |
||
| 134 | +98 |
- #'+ #' AVALC = "" |
||
| 135 | +99 |
- #' basic_table() %>%+ #' ) |
||
| 136 | +100 |
- #' count_abnormal(+ #' |
||
| 137 | +101 |
- #' var = "RANGE",+ #' basic_table() %>% |
||
| 138 | +102 |
- #' abnormal = list(low = "LOW", high = "HIGH"),+ #' split_cols_by("ARM") %>%
|
||
| 139 | +103 |
- #' variables = list(id = "ID", baseline = "BL_RANGE")+ #' add_colcounts() %>% |
||
| 140 | +104 |
- #' ) %>%+ #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
|
||
| 141 | +105 |
- #' build_table(df2)+ #' build_table(anl, alt_counts_df = tern_ex_adsl) |
||
| 142 | +106 |
#' |
||
| 143 | +107 |
#' @export |
||
| 144 | +108 |
#' @order 2 |
||
| 145 | +109 |
- count_abnormal <- function(lyt,+ count_missed_doses <- function(lyt, |
||
| 146 | +110 |
- var,+ vars, |
||
| 147 | +111 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ thresholds, |
||
| 148 | +112 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ var_labels = vars, |
||
| 149 | +113 |
- exclude_base_abn = FALSE,+ show_labels = "visible", |
||
| 150 | +114 |
- na_str = default_na_str(),+ na_str = default_na_str(), |
||
| 151 | +115 |
- nested = TRUE,+ nested = TRUE, |
||
| 152 | +116 |
- ...,+ ..., |
||
| 153 | +117 |
- table_names = var,+ table_names = vars, |
||
| 154 | +118 |
- .stats = NULL,+ .stats = NULL, |
||
| 155 | +119 |
- .formats = NULL,+ .formats = NULL, |
||
| 156 | +120 |
- .labels = NULL,+ .labels = NULL, |
||
| 157 | +121 |
- .indent_mods = NULL) {
+ .indent_mods = NULL) {
|
||
| 158 | -3x | +122 | +1x |
- extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...)+ extra_args <- list(thresholds = thresholds, ...) |
| 159 | +123 | |||
| 160 | -3x | +124 | +1x |
afun <- make_afun( |
| 161 | -3x | +125 | +1x |
- a_count_abnormal,+ a_count_missed_doses, |
| 162 | -3x | +126 | +1x |
.stats = .stats, |
| 163 | -3x | +127 | +1x |
.formats = .formats, |
| 164 | -3x | +128 | +1x |
.labels = .labels, |
| 165 | -3x | +129 | +1x |
.indent_mods = .indent_mods, |
| 166 | -3x | +130 | +1x |
- .ungroup_stats = "fraction"+ .ungroup_stats = "count_fraction" |
| 167 | +131 |
) |
||
| 168 | -- | - - | -||
| 169 | -3x | -
- checkmate::assert_string(var)- |
- ||
| 170 | -+ | 132 | +1x |
-
+ analyze( |
| 171 | -3x | +133 | +1x |
- analyze(+ lyt = lyt, |
| 172 | -3x | +134 | +1x |
- lyt = lyt,+ vars = vars, |
| 173 | -3x | +135 | +1x |
- vars = var,+ afun = afun, |
| 174 | -3x | +136 | +1x |
- afun = afun,+ var_labels = var_labels, |
| 175 | -3x | +137 | +1x |
- na_str = na_str,+ table_names = table_names, |
| 176 | -3x | +138 | +1x |
- nested = nested,+ show_labels = show_labels, |
| 177 | -3x | +139 | +1x |
- table_names = table_names,+ na_str = na_str, |
| 178 | -3x | +140 | +1x |
- extra_args = extra_args,+ nested = nested, |
| 179 | -3x | +141 | +1x |
- show_labels = "hidden"+ extra_args = extra_args |
| 180 | +142 |
) |
||
| 181 | +143 |
}@@ -171263,14 +172235,14 @@ tern coverage - 90.46% |
| 1 |
- #' Counting Specific Values+ #' Cumulative Counts with Thresholds |
||
| 5 |
- #' We can count the occurrence of specific values in a variable of interest.+ #' Summarize cumulative counts of a (`numeric`) vector that is less than, less or equal to, |
||
| 6 |
- #'+ #' greater than, or greater or equal to user-specific thresholds. |
||
| 7 |
- #' @inheritParams argument_convention+ #' |
||
| 8 |
- #' @param values (`character`)\cr specific values that should be counted.+ #' @inheritParams h_count_cumulative |
||
| 9 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_values")`
+ #' @inheritParams argument_convention |
||
| 10 |
- #' to see available statistics for this function.+ #' @param thresholds (`numeric`)\cr vector of cutoff value for the counts. |
||
| 11 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_cumulative")`
|
||
| 12 |
- #' @note+ #' to see available statistics for this function. |
||
| 13 |
- #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x`+ #' |
||
| 14 |
- #' and fails otherwise.+ #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]. |
||
| 15 |
- #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`,+ #' |
||
| 16 |
- #' otherwise they are hidden.+ #' @name count_cumulative |
||
| 17 |
- #'+ #' @order 1 |
||
| 18 |
- #' @name count_values_funs+ NULL |
||
| 19 |
- #' @order 1+ |
||
| 20 |
- NULL+ #' Helper Function for [s_count_cumulative()] |
||
| 21 |
-
+ #' |
||
| 22 |
- #' @describeIn count_values_funs S3 generic function to count values.+ #' @description `r lifecycle::badge("stable")`
|
||
| 24 |
- #' @inheritParams s_summary.logical+ #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold. |
||
| 26 |
- #' @return+ #' @inheritParams argument_convention |
||
| 27 |
- #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable.+ #' @param threshold (`number`)\cr a cutoff value as threshold to count values of `x`. |
||
| 28 |
- #'+ #' @param lower_tail (`logical`)\cr whether to count lower tail, default is `TRUE`. |
||
| 29 |
- #' @export+ #' @param include_eq (`logical`)\cr whether to include value equal to the `threshold` in |
||
| 30 |
- s_count_values <- function(x,+ #' count, default is `TRUE`. |
||
| 31 |
- values,+ #' |
||
| 32 |
- na.rm = TRUE, # nolint+ #' @return A named vector with items: |
||
| 33 |
- .N_col, # nolint+ #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold |
||
| 34 |
- .N_row, # nolint+ #' of user specification. |
||
| 35 |
- denom = c("n", "N_row", "N_col")) {
+ #' * `fraction`: the fraction of the count. |
||
| 36 | -110x | +
- UseMethod("s_count_values", x)
+ #' |
|
| 37 |
- }+ #' @seealso [count_cumulative] |
||
| 38 |
-
+ #' |
||
| 39 |
- #' @describeIn count_values_funs Method for `character` class.+ #' @examples |
||
| 40 |
- #'+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 41 |
- #' @method s_count_values character+ #' x <- c(sample(1:10, 10), NA) |
||
| 42 |
- #'+ #' .N_col <- length(x) |
||
| 43 |
- #' @examples+ #' |
||
| 44 |
- #' # `s_count_values.character`+ #' h_count_cumulative(x, 5, .N_col = .N_col) |
||
| 45 |
- #' s_count_values(x = c("a", "b", "a"), values = "a")
+ #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col) |
||
| 46 |
- #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
+ #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col) |
||
| 47 |
- #'+ #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col) |
||
| 48 |
- #' @export+ #' |
||
| 49 |
- s_count_values.character <- function(x,+ #' @export |
||
| 50 |
- values = "Y",+ h_count_cumulative <- function(x, |
||
| 51 |
- na.rm = TRUE, # nolint+ threshold, |
||
| 52 |
- ...) {
+ lower_tail = TRUE, |
||
| 53 | -108x | +
- checkmate::assert_character(values)+ include_eq = TRUE, |
|
| 54 |
-
+ na.rm = TRUE, # nolint |
||
| 55 | -108x | +
- if (na.rm) {
+ .N_col) { # nolint
|
|
| 56 | -108x | +20x |
- x <- x[!is.na(x)]+ checkmate::assert_numeric(x) |
| 57 | -+ | 20x |
- }+ checkmate::assert_numeric(threshold) |
| 58 | -+ | 20x |
-
+ checkmate::assert_numeric(.N_col) |
| 59 | -108x | +20x |
- is_in_values <- x %in% values+ checkmate::assert_flag(lower_tail) |
| 60 | -+ | 20x |
-
+ checkmate::assert_flag(include_eq) |
| 61 | -108x | +20x |
- s_summary(is_in_values, ...)+ checkmate::assert_flag(na.rm) |
| 62 |
- }+ |
||
| 63 | -+ | 20x |
-
+ is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x)) |
| 64 | -+ | 20x |
- #' @describeIn count_values_funs Method for `factor` class. This makes an automatic+ count <- if (lower_tail && include_eq) {
|
| 65 | -+ | 7x |
- #' conversion to `character` and then forwards to the method for characters.+ length(x[is_keep & x <= threshold]) |
| 66 | -+ | 20x |
- #'+ } else if (lower_tail && !include_eq) {
|
| 67 | -+ | ! |
- #' @method s_count_values factor+ length(x[is_keep & x < threshold]) |
| 68 | -+ | 20x |
- #'+ } else if (!lower_tail && include_eq) {
|
| 69 | -+ | 6x |
- #' @examples+ length(x[is_keep & x >= threshold]) |
| 70 | -+ | 20x |
- #' # `s_count_values.factor`+ } else if (!lower_tail && !include_eq) {
|
| 71 | -+ | 7x |
- #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
+ length(x[is_keep & x > threshold]) |
| 72 |
- #'+ } |
||
| 73 |
- #' @export+ |
||
| 74 | -+ | 20x |
- s_count_values.factor <- function(x,+ result <- c(count = count, fraction = count / .N_col) |
| 75 | -+ | 20x |
- values = "Y",+ result |
| 76 |
- ...) {
+ } |
||
| 77 | -3x | +
- s_count_values(as.character(x), values = as.character(values), ...)+ |
|
| 78 |
- }+ #' Description of Cumulative Count |
||
| 79 |
-
+ #' |
||
| 80 |
- #' @describeIn count_values_funs Method for `logical` class.+ #' @description `r lifecycle::badge("stable")`
|
||
| 82 |
- #' @method s_count_values logical+ #' This is a helper function that describes the analysis in [s_count_cumulative()]. |
||
| 84 |
- #' @examples+ #' @inheritParams h_count_cumulative |
||
| 85 |
- #' # `s_count_values.logical`+ #' |
||
| 86 |
- #' s_count_values(x = c(TRUE, FALSE, TRUE))+ #' @return Labels for [s_count_cumulative()]. |
||
| 89 |
- s_count_values.logical <- function(x, values = TRUE, ...) {
+ d_count_cumulative <- function(threshold, lower_tail, include_eq) {
|
||
| 90 | -3x | +18x |
- checkmate::assert_logical(values)+ checkmate::assert_numeric(threshold) |
| 91 | -3x | +18x |
- s_count_values(as.character(x), values = as.character(values), ...)+ lg <- if (lower_tail) "<" else ">" |
| 92 | -+ | 18x |
- }+ eq <- if (include_eq) "=" else "" |
| 93 | -+ | 18x |
-
+ paste0(lg, eq, " ", threshold) |
| 94 |
- #' @describeIn count_values_funs Formatted analysis function which is used as `afun`+ } |
||
| 95 |
- #' in `count_values()`.+ |
||
| 96 |
- #'+ #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds. |
||
| 97 |
- #' @return+ #' |
||
| 98 |
- #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @return |
||
| 99 |
- #'+ #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a |
||
| 100 |
- #' @examples+ #' component, each component containing a vector for the count and fraction. |
||
| 101 |
- #' # `a_count_values`+ #' |
||
| 102 |
- #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
+ #' @keywords internal |
||
| 103 |
- #'+ s_count_cumulative <- function(x, |
||
| 104 |
- #' @export+ thresholds, |
||
| 105 |
- a_count_values <- make_afun(+ lower_tail = TRUE, |
||
| 106 |
- s_count_values,+ include_eq = TRUE, |
||
| 107 |
- .formats = c(count_fraction = "xx (xx.xx%)", count = "xx")+ .N_col, # nolint |
||
| 108 |
- )+ ...) {
|
||
| 109 | -+ | 5x |
-
+ checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) |
| 110 |
- #' @describeIn count_values_funs Layout-creating function which can take statistics function arguments+ |
||
| 111 | -+ | 5x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ count_fraction_list <- Map(function(thres) {
|
| 112 | -+ | 10x |
- #'+ result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...) |
| 113 | -+ | 10x |
- #' @return+ label <- d_count_cumulative(thres, lower_tail, include_eq) |
| 114 | -+ | 10x |
- #' * `count_values()` returns a layout object suitable for passing to further layouting functions,+ formatters::with_label(result, label) |
| 115 | -+ | 5x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ }, thresholds) |
| 116 |
- #' the statistics from `s_count_values()` to the table layout.+ |
||
| 117 | -+ | 5x |
- #'+ names(count_fraction_list) <- thresholds |
| 118 | -+ | 5x |
- #' @examples+ list(count_fraction = count_fraction_list) |
| 119 |
- #' # `count_values`+ } |
||
| 120 |
- #' basic_table() %>%+ |
||
| 121 |
- #' count_values("Species", values = "setosa") %>%
+ #' @describeIn count_cumulative Formatted analysis function which is used as `afun` |
||
| 122 |
- #' build_table(iris)+ #' in `count_cumulative()`. |
||
| 124 |
- #' @export+ #' @return |
||
| 125 |
- #' @order 2- |
- ||
| 126 | -- |
- count_values <- function(lyt,- |
- |
| 127 | -- |
- vars,- |
- |
| 128 | -- |
- values,- |
- |
| 129 | -- |
- na_str = default_na_str(),- |
- |
| 130 | -- |
- nested = TRUE,- |
- |
| 131 | -- |
- ...,- |
- |
| 132 | -- |
- table_names = vars,- |
- |
| 133 | -- |
- .stats = "count_fraction",- |
- |
| 134 | -- |
- .formats = NULL,- |
- |
| 135 | -- |
- .labels = c(count_fraction = paste(values, collapse = ", ")),- |
- |
| 136 | -- |
- .indent_mods = NULL) {
- |
- |
| 137 | -3x | -
- extra_args <- list(values = values, ...)- |
- |
| 138 | -- | - - | -|
| 139 | -3x | -
- afun <- make_afun(- |
- |
| 140 | -3x | -
- a_count_values,- |
- |
| 141 | -3x | -
- .stats = .stats,- |
- |
| 142 | -3x | -
- .formats = .formats,- |
- |
| 143 | -3x | -
- .labels = .labels,- |
- |
| 144 | -3x | -
- .indent_mods = .indent_mods- |
- |
| 145 | -- |
- )- |
- |
| 146 | -3x | -
- analyze(- |
- |
| 147 | -3x | -
- lyt,- |
- |
| 148 | -3x | -
- vars,- |
- |
| 149 | -3x | -
- afun = afun,- |
- |
| 150 | -3x | -
- na_str = na_str,- |
- |
| 151 | -3x | -
- nested = nested,- |
- |
| 152 | -3x | -
- extra_args = extra_args,- |
- |
| 153 | -3x | -
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),- |
- |
| 154 | -3x | -
- table_names = table_names- |
- |
| 155 | -- |
- )- |
- |
| 156 | -- |
- }- |
-
| 1 | -- |
- #' Subgroup Treatment Effect Pattern (STEP) Fit for Survival Outcome- |
- |
| 2 | -- |
- #'+ #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 3 | +126 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
|
| 4 | +127 |
- #'+ #' @keywords internal |
|
| 5 | +128 |
- #' This fits the Subgroup Treatment Effect Pattern models for a survival outcome. The treatment arm+ a_count_cumulative <- make_afun( |
|
| 6 | +129 |
- #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated+ s_count_cumulative, |
|
| 7 | +130 |
- #' hazard ratios are for the comparison of the second level vs. the first one.+ .formats = c(count_fraction = format_count_fraction) |
|
| 8 | +131 |
- #'+ ) |
|
| 9 | +132 |
- #' The model which is fit is:+ |
|
| 10 | +133 |
- #'+ #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments |
|
| 11 | +134 |
- #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 12 | +135 |
#' |
|
| 13 | +136 |
- #' where `degree` is specified by `control_step()`.+ #' @return |
|
| 14 | +137 |
- #'+ #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions, |
|
| 15 | +138 |
- #' @inheritParams argument_convention+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 16 | +139 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`,+ #' the statistics from `s_count_cumulative()` to the table layout. |
|
| 17 | +140 |
- #' `arm`, `biomarker`, and optional `covariates` and `strata`.+ #' |
|
| 18 | +141 |
- #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].+ #' @examples |
|
| 19 | +142 |
- #'+ #' basic_table() %>% |
|
| 20 | +143 |
- #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used+ #' split_cols_by("ARM") %>%
|
|
| 21 | +144 |
- #' for the biomarker variable, including where the center of the intervals are and their bounds. The+ #' add_colcounts() %>% |
|
| 22 | +145 |
- #' second part of the columns contain the estimates for the treatment arm comparison.+ #' count_cumulative( |
|
| 23 | +146 |
- #'+ #' vars = "AGE", |
|
| 24 | +147 |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ #' thresholds = c(40, 60) |
|
| 25 | +148 |
- #'+ #' ) %>% |
|
| 26 | +149 |
- #' @seealso [control_step()] and [control_coxph()] for the available customization options.+ #' build_table(tern_ex_adsl) |
|
| 27 | +150 |
#' |
|
| 28 | +151 |
- #' @examples+ #' @export |
|
| 29 | +152 |
- #' # Testing dataset with just two treatment arms.+ #' @order 2 |
|
| 30 | +153 |
- #' library(dplyr)+ count_cumulative <- function(lyt, |
|
| 31 | +154 |
- #'+ vars, |
|
| 32 | +155 |
- #' adtte_f <- tern_ex_adtte %>%+ thresholds, |
|
| 33 | +156 |
- #' filter(+ lower_tail = TRUE, |
|
| 34 | +157 |
- #' PARAMCD == "OS",+ include_eq = TRUE, |
|
| 35 | +158 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ var_labels = vars, |
|
| 36 | +159 |
- #' ) %>%+ show_labels = "visible", |
|
| 37 | +160 |
- #' mutate(+ na_str = default_na_str(), |
|
| 38 | +161 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ nested = TRUE, |
|
| 39 | +162 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ ..., |
|
| 40 | +163 |
- #' is_event = CNSR == 0+ table_names = vars, |
|
| 41 | +164 |
- #' )+ .stats = NULL, |
|
| 42 | +165 |
- #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
+ .formats = NULL, |
|
| 43 | +166 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ .labels = NULL, |
|
| 44 | +167 |
- #'+ .indent_mods = NULL) {
|
|
| 45 | -+ | ||
| 168 | +2x |
- #' variables <- list(+ extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...) |
|
| 46 | +169 |
- #' arm = "ARM",+ |
|
| 47 | -+ | ||
| 170 | +2x |
- #' biomarker = "BMRKR1",+ afun <- make_afun( |
|
| 48 | -+ | ||
| 171 | +2x |
- #' covariates = c("AGE", "BMRKR2"),
+ a_count_cumulative, |
|
| 49 | -+ | ||
| 172 | +2x |
- #' event = "is_event",+ .stats = .stats, |
|
| 50 | -+ | ||
| 173 | +2x |
- #' time = "AVAL"+ .formats = .formats, |
|
| 51 | -+ | ||
| 174 | +2x |
- #' )+ .labels = .labels, |
|
| 52 | -+ | ||
| 175 | +2x |
- #'+ .indent_mods = .indent_mods, |
|
| 53 | -+ | ||
| 176 | +2x |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ .ungroup_stats = "count_fraction" |
|
| 54 | +177 |
- #' step_matrix <- fit_survival_step(+ ) |
|
| 55 | -+ | ||
| 178 | +2x |
- #' variables = variables,+ analyze( |
|
| 56 | -+ | ||
| 179 | +2x |
- #' data = adtte_f+ lyt, |
|
| 57 | -+ | ||
| 180 | +2x |
- #' )+ vars, |
|
| 58 | -+ | ||
| 181 | +2x |
- #' dim(step_matrix)+ afun = afun, |
|
| 59 | -+ | ||
| 182 | +2x |
- #' head(step_matrix)+ na_str = na_str, |
|
| 60 | -+ | ||
| 183 | +2x |
- #'+ table_names = table_names, |
|
| 61 | -+ | ||
| 184 | +2x |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ var_labels = var_labels, |
|
| 62 | -+ | ||
| 185 | +2x |
- #' # models. Or specify different Cox regression options.+ show_labels = show_labels, |
|
| 63 | -+ | ||
| 186 | +2x |
- #' step_matrix2 <- fit_survival_step(+ nested = nested, |
|
| 64 | -+ | ||
| 187 | +2x |
- #' variables = variables,+ extra_args = extra_args |
|
| 65 | +188 |
- #' data = adtte_f,+ ) |
|
| 66 | +189 |
- #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))+ } |
| 67 | +1 |
- #' )+ #' Number of Patients |
||
| 68 | +2 |
#' |
||
| 69 | +3 |
- #' # Use a global model with cubic interaction and only 5 points.+ #' @description `r lifecycle::badge("stable")`
|
||
| 70 | +4 |
- #' step_matrix3 <- fit_survival_step(+ #' |
||
| 71 | +5 |
- #' variables = variables,+ #' Count the number of unique and non-unique patients in a column (variable). |
||
| 72 | +6 |
- #' data = adtte_f,+ #' |
||
| 73 | +7 |
- #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))+ #' @inheritParams argument_convention |
||
| 74 | +8 |
- #' )+ #' @param count_by (`vector`)\cr optional vector of any type to be combined with `x` when counting `nonunique` |
||
| 75 | +9 |
- #'+ #' records. |
||
| 76 | +10 |
- #' @export+ #' @param unique_count_suffix (`logical`)\cr should `"(n)"` suffix be added to `unique_count` labels. |
||
| 77 | +11 |
- fit_survival_step <- function(variables,+ #' Defaults to `TRUE`. |
||
| 78 | +12 |
- data,+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_num_patients")`
|
||
| 79 | +13 |
- control = c(control_step(), control_coxph())) {
+ #' to see available statistics for this function. |
||
| 80 | -4x | +|||
| 14 | +
- checkmate::assert_list(control)+ #' |
|||
| 81 | -4x | +|||
| 15 | +
- assert_df_with_variables(data, variables)+ #' @name summarize_num_patients |
|||
| 82 | -4x | +|||
| 16 | +
- data <- data[!is.na(data[[variables$biomarker]]), ]+ #' @order 1 |
|||
| 83 | -4x | +|||
| 17 | +
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ NULL |
|||
| 84 | -4x | +|||
| 18 | +
- interval_center <- window_sel$interval[, "Interval Center"]+ |
|||
| 85 | -4x | +|||
| 19 | +
- form <- h_step_survival_formula(variables = variables, control = control)+ #' @describeIn summarize_num_patients Statistics function which counts the number of |
|||
| 86 | -4x | +|||
| 20 | +
- estimates <- if (is.null(control$bandwidth)) {
+ #' unique patients, the corresponding percentage taken with respect to the |
|||
| 87 | -1x | +|||
| 21 | +
- h_step_survival_est(+ #' total number of patients, and the number of non-unique patients. |
|||
| 88 | -1x | +|||
| 22 | +
- formula = form,+ #' |
|||
| 89 | -1x | +|||
| 23 | +
- data = data,+ #' @param x (`character` or `factor`)\cr vector of patient IDs. |
|||
| 90 | -1x | +|||
| 24 | +
- variables = variables,+ #' |
|||
| 91 | -1x | +|||
| 25 | +
- x = interval_center,+ #' @return |
|||
| 92 | -1x | +|||
| 26 | +
- control = control+ #' * `s_num_patients()` returns a named `list` of 3 statistics: |
|||
| 93 | +27 |
- )+ #' * `unique`: Vector of counts and percentages. |
||
| 94 | +28 |
- } else {
+ #' * `nonunique`: Vector of counts. |
||
| 95 | -3x | +|||
| 29 | +
- tmp <- mapply(+ #' * `unique_count`: Counts. |
|||
| 96 | -3x | +|||
| 30 | +
- FUN = h_step_survival_est,+ #' |
|||
| 97 | -3x | +|||
| 31 | +
- x = interval_center,+ #' @examples |
|||
| 98 | -3x | +|||
| 32 | +
- subset = as.list(as.data.frame(window_sel$sel)),+ #' # Use the statistics function to count number of unique and nonunique patients. |
|||
| 99 | -3x | +|||
| 33 | +
- MoreArgs = list(+ #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L) |
|||
| 100 | -3x | +|||
| 34 | +
- formula = form,+ #' s_num_patients( |
|||
| 101 | -3x | +|||
| 35 | +
- data = data,+ #' x = as.character(c(1, 1, 1, 2, 4, NA)), |
|||
| 102 | -3x | +|||
| 36 | +
- variables = variables,+ #' labelstr = "", |
|||
| 103 | -3x | +|||
| 37 | +
- control = control+ #' .N_col = 6L, |
|||
| 104 | +38 |
- )+ #' count_by = c(1, 1, 2, 1, 1, 1) |
||
| 105 | +39 |
- )+ #' ) |
||
| 106 | +40 |
- # Maybe we find a more elegant solution than this.+ #' |
||
| 107 | -3x | +|||
| 41 | +
- rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
+ #' @export |
|||
| 108 | -3x | +|||
| 42 | +
- t(tmp)+ s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
|
|||
| 109 | +43 |
- }+ |
||
| 110 | -4x | +44 | +109x |
- result <- cbind(window_sel$interval, estimates)+ checkmate::assert_string(labelstr) |
| 111 | -4x | +45 | +109x |
- structure(+ checkmate::assert_count(.N_col) |
| 112 | -4x | +46 | +109x |
- result,+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
| 113 | -4x | +47 | +109x |
- class = c("step", "matrix"),
+ checkmate::assert_flag(unique_count_suffix)+ |
+
| 48 | ++ | + | ||
| 114 | -4x | +49 | +109x |
- variables = variables,+ count1 <- n_available(unique(x)) |
| 115 | -4x | +50 | +109x |
- control = control+ count2 <- n_available(x) |
| 116 | +51 |
- )+ |
||
| 117 | -+ | |||
| 52 | +109x |
- }+ if (!is.null(count_by)) {
|
| 1 | -+ | |||
| 53 | +10x |
- #' Counting Missed Doses+ checkmate::assert_vector(count_by, len = length(x)) |
||
| 2 | -+ | |||
| 54 | +10x |
- #'+ count2 <- n_available(unique(interaction(x, count_by))) |
||
| 3 | +55 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +56 |
- #'+ |
||
| 5 | -+ | |||
| 57 | +109x |
- #' These are specific functions to count patients with missed doses. The difference to [count_cumulative()] is+ out <- list( |
||
| 6 | -+ | |||
| 58 | +109x |
- #' mainly the special labels.+ unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr), |
||
| 7 | -+ | |||
| 59 | +109x |
- #'+ nonunique = formatters::with_label(count2, labelstr), |
||
| 8 | -+ | |||
| 60 | +109x |
- #' @inheritParams s_count_cumulative+ unique_count = formatters::with_label( |
||
| 9 | -+ | |||
| 61 | +109x |
- #' @inheritParams argument_convention+ count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr) |
||
| 10 | +62 |
- #' @param thresholds (vector of `count`)\cr number of missed doses the patients at least had.+ ) |
||
| 11 | +63 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_missed_doses")`
+ ) |
||
| 12 | +64 |
- #' to see available statistics for this function.+ |
||
| 13 | -+ | |||
| 65 | +109x |
- #'+ out |
||
| 14 | +66 |
- #' @seealso Relevant description function [d_count_missed_doses()].+ } |
||
| 15 | +67 |
- #'+ |
||
| 16 | +68 |
- #' @name count_missed_doses+ #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients |
||
| 17 | +69 |
- #' @order 1+ #' in a column (variable), the corresponding percentage taken with respect to the total number of |
||
| 18 | +70 |
- NULL+ #' patients, and the number of non-unique patients in the column. |
||
| 19 | +71 |
-
+ #' |
||
| 20 | +72 |
- #' @describeIn count_missed_doses Statistics function to count non-missing values.+ #' @param required (`character` or `NULL`)\cr optional name of a variable that is required to be non-missing. |
||
| 21 | +73 |
#' |
||
| 22 | +74 |
#' @return |
||
| 23 | +75 |
- #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`.+ #' * `s_num_patients_content()` returns the same values as `s_num_patients()`. |
||
| 24 | +76 |
#' |
||
| 25 | +77 |
- #' @keywords internal+ #' @examples |
||
| 26 | +78 |
- s_count_nonmissing <- function(x) {
+ #' # Count number of unique and non-unique patients. |
||
| 27 | -5x | +|||
| 79 | +
- list(n = n_available(x))+ #' |
|||
| 28 | +80 |
- }+ #' df <- data.frame( |
||
| 29 | +81 |
-
+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
||
| 30 | +82 |
- #' Description Function that Calculates Labels for [s_count_missed_doses()].+ #' EVENT = as.character(c(10, 15, 10, 17, 8)) |
||
| 31 | +83 |
- #'+ #' ) |
||
| 32 | +84 |
- #' @description `r lifecycle::badge("stable")`
+ #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID") |
||
| 33 | +85 |
#' |
||
| 34 | +86 |
- #' @inheritParams s_count_missed_doses+ #' df_by_event <- data.frame( |
||
| 35 | +87 |
- #'+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
||
| 36 | +88 |
- #' @return [d_count_missed_doses()] returns a named `character` vector with the labels.+ #' EVENT = c(10, 15, 10, 17, 8) |
||
| 37 | +89 |
- #'+ #' ) |
||
| 38 | +90 |
- #' @seealso [s_count_missed_doses()]+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT") |
||
| 39 | +91 |
#' |
||
| 40 | +92 |
#' @export |
||
| 41 | +93 |
- d_count_missed_doses <- function(thresholds) {
- |
- ||
| 42 | -4x | -
- paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
+ s_num_patients_content <- function(df, |
||
| 43 | +94 |
- }+ labelstr = "", |
||
| 44 | +95 |
-
+ .N_col, # nolint |
||
| 45 | +96 |
- #' @describeIn count_missed_doses Statistics function to count patients with missed doses.+ .var, |
||
| 46 | +97 |
- #'+ required = NULL, |
||
| 47 | +98 |
- #' @return+ count_by = NULL, |
||
| 48 | +99 |
- #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold.+ unique_count_suffix = TRUE) {
|
||
| 49 | -+ | |||
| 100 | +46x |
- #'+ checkmate::assert_string(.var) |
||
| 50 | -+ | |||
| 101 | +46x |
- #' @keywords internal+ checkmate::assert_data_frame(df) |
||
| 51 | -+ | |||
| 102 | +46x |
- s_count_missed_doses <- function(x,+ if (is.null(count_by)) {
|
||
| 52 | -+ | |||
| 103 | +43x |
- thresholds,+ assert_df_with_variables(df, list(id = .var)) |
||
| 53 | +104 |
- .N_col) { # nolint
+ } else {
|
||
| 54 | -1x | +105 | +3x |
- stat <- s_count_cumulative(+ assert_df_with_variables(df, list(id = .var, count_by = count_by)) |
| 55 | -1x | +|||
| 106 | +
- x = x,+ } |
|||
| 56 | -1x | +107 | +46x |
- thresholds = thresholds,+ if (!is.null(required)) {
|
| 57 | -1x | +|||
| 108 | +! |
- lower_tail = FALSE,+ checkmate::assert_string(required) |
||
| 58 | -1x | +|||
| 109 | +! |
- include_eq = TRUE,+ assert_df_with_variables(df, list(required = required)) |
||
| 59 | -1x | +|||
| 110 | +! |
- .N_col = .N_col+ df <- df[!is.na(df[[required]]), , drop = FALSE] |
||
| 60 | +111 |
- )+ } |
||
| 61 | -1x | +|||
| 112 | +
- labels <- d_count_missed_doses(thresholds)+ |
|||
| 62 | -1x | +113 | +46x |
- for (i in seq_along(stat$count_fraction)) {
+ x <- df[[.var]] |
| 63 | -2x | +114 | +46x |
- stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])+ y <- if (is.null(count_by)) NULL else df[[count_by]] |
| 64 | +115 |
- }+ |
||
| 65 | -1x | +116 | +46x |
- n_stat <- s_count_nonmissing(x)+ s_num_patients( |
| 66 | -1x | -
- c(n_stat, stat)- |
- ||
| 67 | -+ | 117 | +46x |
- }+ x = x, |
| 68 | -+ | |||
| 118 | +46x |
-
+ labelstr = labelstr, |
||
| 69 | -+ | |||
| 119 | +46x |
- #' @describeIn count_missed_doses Formatted analysis function which is used as `afun`- |
- ||
| 70 | -+ | |||
| 120 | +46x |
- #' in `count_missed_doses()`.+ count_by = y, |
||
| 71 | -+ | |||
| 121 | +46x |
- #'+ unique_count_suffix = unique_count_suffix |
||
| 72 | +122 |
- #' @return+ ) |
||
| 73 | +123 |
- #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
||
| 74 | +124 |
- #'+ |
||
| 75 | +125 |
- #' @keywords internal+ c_num_patients <- make_afun( |
||
| 76 | +126 |
- a_count_missed_doses <- make_afun(+ s_num_patients_content, |
||
| 77 | +127 |
- s_count_missed_doses,+ .stats = c("unique", "nonunique", "unique_count"),
|
||
| 78 | +128 |
- .formats = c(n = "xx", count_fraction = format_count_fraction)+ .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx") |
||
| 79 | +129 |
) |
||
| 80 | +130 | |||
| 81 | +131 |
- #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 82 | +132 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 83 | +133 |
#' |
||
| 84 | +134 |
#' @return |
||
| 85 | +135 |
- #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions,+ #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 86 | +136 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 87 | +137 |
- #' the statistics from `s_count_missed_doses()` to the table layout.+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 88 | +138 |
#' |
||
| 89 | +139 |
- #' @examples+ #' @export |
||
| 90 | +140 |
- #' library(dplyr)+ #' @order 3 |
||
| 91 | +141 |
- #'+ summarize_num_patients <- function(lyt, |
||
| 92 | +142 |
- #' anl <- tern_ex_adsl %>%+ var, |
||
| 93 | +143 |
- #' distinct(STUDYID, USUBJID, ARM) %>%+ required = NULL, |
||
| 94 | +144 |
- #' mutate(+ count_by = NULL, |
||
| 95 | +145 |
- #' PARAMCD = "TNDOSMIS",+ unique_count_suffix = TRUE, |
||
| 96 | +146 |
- #' PARAM = "Total number of missed doses during study",+ na_str = default_na_str(), |
||
| 97 | +147 |
- #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE),+ .stats = NULL, |
||
| 98 | +148 |
- #' AVALC = ""+ .formats = NULL, |
||
| 99 | +149 |
- #' )+ .labels = c( |
||
| 100 | +150 |
- #'+ unique = "Number of patients with at least one event", |
||
| 101 | +151 |
- #' basic_table() %>%+ nonunique = "Number of events" |
||
| 102 | +152 |
- #' split_cols_by("ARM") %>%
+ ), |
||
| 103 | +153 |
- #' add_colcounts() %>%+ indent_mod = lifecycle::deprecated(), |
||
| 104 | +154 |
- #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
+ .indent_mods = 0L, |
||
| 105 | +155 |
- #' build_table(anl, alt_counts_df = tern_ex_adsl)+ riskdiff = FALSE, |
||
| 106 | +156 |
- #'+ ...) {
|
||
| 107 | -+ | |||
| 157 | +9x |
- #' @export+ checkmate::assert_flag(riskdiff) |
||
| 108 | +158 |
- #' @order 2+ |
||
| 109 | -+ | |||
| 159 | +9x |
- count_missed_doses <- function(lyt,+ if (lifecycle::is_present(indent_mod)) {
|
||
| 110 | -+ | |||
| 160 | +! |
- vars,+ lifecycle::deprecate_warn("0.8.2", "summarize_num_patients(indent_mod)", "summarize_num_patients(.indent_mods)")
|
||
| 111 | -+ | |||
| 161 | +! |
- thresholds,+ .indent_mods <- indent_mod |
||
| 112 | +162 |
- var_labels = vars,+ } |
||
| 113 | +163 |
- show_labels = "visible",+ |
||
| 114 | -+ | |||
| 164 | +4x |
- na_str = default_na_str(),+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
||
| 115 | -+ | |||
| 165 | +2x |
- nested = TRUE,+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
||
| 116 | +166 |
- ...,+ |
||
| 117 | -+ | |||
| 167 | +9x |
- table_names = vars,+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...) |
||
| 118 | +168 |
- .stats = NULL,+ |
||
| 119 | -+ | |||
| 169 | +9x |
- .formats = NULL,+ cfun <- make_afun( |
||
| 120 | -+ | |||
| 170 | +9x |
- .labels = NULL,+ c_num_patients, |
||
| 121 | -+ | |||
| 171 | +9x |
- .indent_mods = NULL) {
+ .stats = .stats, |
||
| 122 | -1x | +172 | +9x |
- extra_args <- list(thresholds = thresholds, ...)+ .formats = .formats,+ |
+
| 173 | +9x | +
+ .labels = .labels |
||
| 123 | +174 | ++ |
+ )+ |
+ |
| 175 | ||||
| 124 | -1x | +176 | +9x |
- afun <- make_afun(+ extra_args <- if (isFALSE(riskdiff)) {
|
| 125 | -1x | +177 | +8x |
- a_count_missed_doses,+ s_args+ |
+
| 178 | ++ |
+ } else {
|
||
| 126 | +179 | 1x |
- .stats = .stats,+ list( |
|
| 127 | +180 | 1x |
- .formats = .formats,+ afun = list("s_num_patients_content" = cfun),
|
|
| 128 | +181 | 1x |
- .labels = .labels,+ .stats = .stats, |
|
| 129 | +182 | 1x |
- .indent_mods = .indent_mods,+ .indent_mods = .indent_mods, |
|
| 130 | +183 | 1x |
- .ungroup_stats = "count_fraction"+ s_args = s_args |
|
| 131 | +184 |
- )- |
- ||
| 132 | -1x | -
- analyze(+ ) |
||
| 133 | -1x | +|||
| 185 | +
- lyt = lyt,+ } |
|||
| 134 | -1x | +|||
| 186 | +
- vars = vars,+ |
|||
| 135 | -1x | +187 | +9x |
- afun = afun,+ summarize_row_groups( |
| 136 | -1x | +188 | +9x |
- var_labels = var_labels,+ lyt = lyt, |
| 137 | -1x | +189 | +9x |
- table_names = table_names,+ var = var, |
| 138 | -1x | +190 | +9x |
- show_labels = show_labels,+ cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff), |
| 139 | -1x | +191 | +9x |
na_str = na_str, |
| 140 | -1x | +192 | +9x |
- nested = nested,+ extra_args = extra_args, |
| 141 | -1x | +193 | +9x |
- extra_args = extra_args+ indent_mod = .indent_mods |
| 142 | +194 |
) |
||
| 143 | +195 |
} |
| 1 | +196 |
- #' Cumulative Counts with Thresholds+ |
||
| 2 | +197 |
- #'+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 3 | +198 |
- #' @description `r lifecycle::badge("stable")`
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 4 | +199 |
#' |
||
| 5 | +200 |
- #' Summarize cumulative counts of a (`numeric`) vector that is less than, less or equal to,+ #' @return |
||
| 6 | +201 |
- #' greater than, or greater or equal to user-specific thresholds.+ #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 7 | +202 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 8 | +203 |
- #' @inheritParams h_count_cumulative+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 9 | +204 |
- #' @inheritParams argument_convention+ #' |
||
| 10 | +205 |
- #' @param thresholds (`numeric`)\cr vector of cutoff value for the counts.+ #' @details In general, functions that starts with `analyze*` are expected to |
||
| 11 | +206 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_cumulative")`
+ #' work like [rtables::analyze()], while functions that starts with `summarize*` |
||
| 12 | +207 |
- #' to see available statistics for this function.+ #' are based upon [rtables::summarize_row_groups()]. The latter provides a |
||
| 13 | +208 |
- #'+ #' value for each dividing split in the row and column space, but, being it |
||
| 14 | +209 |
- #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()].+ #' bound to the fundamental splits, it is repeated by design in every page |
||
| 15 | +210 |
- #'+ #' when pagination is involved. |
||
| 16 | +211 |
- #' @name count_cumulative+ #' |
||
| 17 | +212 |
- #' @order 1+ #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows. |
||
| 18 | +213 |
- NULL+ #' |
||
| 19 | +214 |
-
+ #' @examples |
||
| 20 | +215 |
- #' Helper Function for [s_count_cumulative()]+ #' df <- data.frame( |
||
| 21 | +216 |
- #'+ #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)), |
||
| 22 | +217 |
- #' @description `r lifecycle::badge("stable")`
+ #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
|
||
| 23 | +218 |
- #'+ #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17) |
||
| 24 | +219 |
- #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.+ #' ) |
||
| 25 | +220 |
#' |
||
| 26 | +221 |
- #' @inheritParams argument_convention+ #' tbl <- basic_table() %>% |
||
| 27 | +222 |
- #' @param threshold (`number`)\cr a cutoff value as threshold to count values of `x`.+ #' split_cols_by("ARM") %>%
|
||
| 28 | +223 |
- #' @param lower_tail (`logical`)\cr whether to count lower tail, default is `TRUE`.+ #' add_colcounts() %>% |
||
| 29 | +224 |
- #' @param include_eq (`logical`)\cr whether to include value equal to the `threshold` in+ #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
|
||
| 30 | +225 |
- #' count, default is `TRUE`.+ #' build_table(df) |
||
| 31 | +226 |
#' |
||
| 32 | -- |
- #' @return A named vector with items:- |
- ||
| 33 | -- |
- #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold- |
- ||
| 34 | +227 |
- #' of user specification.+ #' tbl |
||
| 35 | +228 |
- #' * `fraction`: the fraction of the count.+ #' |
||
| 36 | +229 |
- #'+ #' @export |
||
| 37 | +230 |
- #' @seealso [count_cumulative]+ #' @order 2 |
||
| 38 | +231 |
- #'+ analyze_num_patients <- function(lyt, |
||
| 39 | +232 |
- #' @examples+ vars, |
||
| 40 | +233 |
- #' set.seed(1, kind = "Mersenne-Twister")+ required = NULL, |
||
| 41 | +234 |
- #' x <- c(sample(1:10, 10), NA)+ count_by = NULL, |
||
| 42 | +235 |
- #' .N_col <- length(x)+ unique_count_suffix = TRUE, |
||
| 43 | +236 |
- #'+ na_str = default_na_str(), |
||
| 44 | +237 |
- #' h_count_cumulative(x, 5, .N_col = .N_col)+ nested = TRUE, |
||
| 45 | +238 |
- #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)+ .stats = NULL, |
||
| 46 | +239 |
- #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)+ .formats = NULL, |
||
| 47 | +240 |
- #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)+ .labels = c( |
||
| 48 | +241 |
- #'+ unique = "Number of patients with at least one event", |
||
| 49 | +242 |
- #' @export+ nonunique = "Number of events" |
||
| 50 | +243 |
- h_count_cumulative <- function(x,+ ), |
||
| 51 | +244 |
- threshold,+ show_labels = c("default", "visible", "hidden"),
|
||
| 52 | +245 |
- lower_tail = TRUE,+ indent_mod = lifecycle::deprecated(), |
||
| 53 | +246 |
- include_eq = TRUE,+ .indent_mods = 0L, |
||
| 54 | +247 |
- na.rm = TRUE, # nolint+ riskdiff = FALSE, |
||
| 55 | +248 |
- .N_col) { # nolint
- |
- ||
| 56 | -20x | -
- checkmate::assert_numeric(x)- |
- ||
| 57 | -20x | -
- checkmate::assert_numeric(threshold)- |
- ||
| 58 | -20x | -
- checkmate::assert_numeric(.N_col)- |
- ||
| 59 | -20x | -
- checkmate::assert_flag(lower_tail)- |
- ||
| 60 | -20x | -
- checkmate::assert_flag(include_eq)+ ...) {
|
||
| 61 | -20x | +249 | +3x |
- checkmate::assert_flag(na.rm)+ checkmate::assert_flag(riskdiff) |
| 62 | +250 | |||
| 63 | -20x | -
- is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))- |
- ||
| 64 | -20x | -
- count <- if (lower_tail && include_eq) {
- |
- ||
| 65 | -7x | -
- length(x[is_keep & x <= threshold])- |
- ||
| 66 | -20x | +251 | +3x |
- } else if (lower_tail && !include_eq) {
+ if (lifecycle::is_present(indent_mod)) {
|
| 67 | +252 | ! |
- length(x[is_keep & x < threshold])- |
- |
| 68 | -20x | -
- } else if (!lower_tail && include_eq) {
- |
- ||
| 69 | -6x | -
- length(x[is_keep & x >= threshold])- |
- ||
| 70 | -20x | -
- } else if (!lower_tail && !include_eq) {
+ lifecycle::deprecate_warn("0.8.2", "analyze_num_patients(indent_mod)", "analyze_num_patients(.indent_mods)")
|
||
| 71 | -7x | +|||
| 253 | +! |
- length(x[is_keep & x > threshold])+ .indent_mods <- indent_mod |
||
| 72 | +254 |
} |
||
| 73 | +255 | |||
| 74 | -20x | -
- result <- c(count = count, fraction = count / .N_col)- |
- ||
| 75 | -20x | +|||
| 256 | +! |
- result+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
||
| 76 | -+ | |||
| 257 | +! |
- }+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
||
| 77 | +258 | |||
| 78 | -- |
- #' Description of Cumulative Count- |
- ||
| 79 | -- |
- #'- |
- ||
| 80 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 81 | -- |
- #'- |
- ||
| 82 | -- |
- #' This is a helper function that describes the analysis in [s_count_cumulative()].- |
- ||
| 83 | -- |
- #'- |
- ||
| 84 | -- |
- #' @inheritParams h_count_cumulative- |
- ||
| 85 | -- |
- #'- |
- ||
| 86 | -- |
- #' @return Labels for [s_count_cumulative()].- |
- ||
| 87 | -+ | |||
| 259 | +3x |
- #'+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...) |
||
| 88 | +260 |
- #' @export+ |
||
| 89 | -+ | |||
| 261 | +3x |
- d_count_cumulative <- function(threshold, lower_tail, include_eq) {
+ afun <- make_afun( |
||
| 90 | -18x | +262 | +3x |
- checkmate::assert_numeric(threshold)+ c_num_patients, |
| 91 | -18x | +263 | +3x |
- lg <- if (lower_tail) "<" else ">"+ .stats = .stats, |
| 92 | -18x | +264 | +3x |
- eq <- if (include_eq) "=" else ""+ .formats = .formats, |
| 93 | -18x | +265 | +3x |
- paste0(lg, eq, " ", threshold)+ .labels = .labels |
| 94 | +266 |
- }+ ) |
||
| 95 | +267 | |||
| 96 | -- |
- #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds.- |
- ||
| 97 | -- |
- #'- |
- ||
| 98 | -+ | |||
| 268 | +3x |
- #' @return+ extra_args <- if (isFALSE(riskdiff)) {
|
||
| 99 | -+ | |||
| 269 | +2x |
- #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a+ s_args |
||
| 100 | +270 |
- #' component, each component containing a vector for the count and fraction.+ } else {
|
||
| 101 | -+ | |||
| 271 | +1x |
- #'+ list( |
||
| 102 | -+ | |||
| 272 | +1x |
- #' @keywords internal+ afun = list("s_num_patients_content" = afun),
|
||
| 103 | -+ | |||
| 273 | +1x |
- s_count_cumulative <- function(x,+ .stats = .stats, |
||
| 104 | -+ | |||
| 274 | +1x |
- thresholds,+ .indent_mods = .indent_mods, |
||
| 105 | -+ | |||
| 275 | +1x |
- lower_tail = TRUE,+ s_args = s_args |
||
| 106 | +276 |
- include_eq = TRUE,+ ) |
||
| 107 | +277 |
- .N_col, # nolint+ } |
||
| 108 | +278 |
- ...) {
+
|
||
| 109 | -5x | -
- checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)- |
- ||
| 110 | -+ | 279 | +3x |
-
+ analyze( |
| 111 | -5x | +280 | +3x |
- count_fraction_list <- Map(function(thres) {
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 112 | -10x | +281 | +3x |
- result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...)+ lyt = lyt, |
| 113 | -10x | +282 | +3x |
- label <- d_count_cumulative(thres, lower_tail, include_eq)+ vars = vars, |
| 114 | -10x | +283 | +3x |
- formatters::with_label(result, label)+ na_str = na_str, |
| 115 | -5x | +284 | +3x |
- }, thresholds)+ nested = nested, |
| 116 | -+ | |||
| 285 | +3x |
-
+ extra_args = extra_args, |
||
| 117 | -5x | +286 | +3x |
- names(count_fraction_list) <- thresholds+ show_labels = show_labels, |
| 118 | -5x | +287 | +3x |
- list(count_fraction = count_fraction_list)+ indent_mod = .indent_mods |
| 119 | +288 |
- }+ ) |
||
| 120 | +289 |
-
+ } |
| 121 | +1 |
- #' @describeIn count_cumulative Formatted analysis function which is used as `afun`+ #' Helper Functions for Tabulating Biomarker Effects on Binary Response by Subgroup |
||
| 122 | +2 |
- #' in `count_cumulative()`.+ #' |
||
| 123 | +3 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 124 | +4 |
- #' @return+ #' |
||
| 125 | +5 |
- #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].+ #' Helper functions which are documented here separately to not confuse the user |
||
| 126 | +6 |
- #'+ #' when reading about the user-facing functions. |
||
| 127 | +7 |
- #' @keywords internal+ #' |
||
| 128 | +8 |
- a_count_cumulative <- make_afun(+ #' @inheritParams response_biomarkers_subgroups |
||
| 129 | +9 |
- s_count_cumulative,+ #' @inheritParams extract_rsp_biomarkers |
||
| 130 | +10 |
- .formats = c(count_fraction = format_count_fraction)+ #' @inheritParams argument_convention |
||
| 131 | +11 |
- )+ #' |
||
| 132 | +12 |
-
+ #' @examples |
||
| 133 | +13 |
- #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments+ #' library(dplyr) |
||
| 134 | +14 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' library(forcats) |
||
| 135 | +15 |
#' |
||
| 136 | +16 |
- #' @return+ #' adrs <- tern_ex_adrs |
||
| 137 | +17 |
- #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions,+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 138 | +18 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 139 | +19 |
- #' the statistics from `s_count_cumulative()` to the table layout.+ #' adrs_f <- adrs %>% |
||
| 140 | +20 |
- #'+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 141 | +21 |
- #' @examples+ #' mutate(rsp = AVALC == "CR") |
||
| 142 | +22 |
- #' basic_table() %>%+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 143 | +23 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 144 | +24 |
- #' add_colcounts() %>%+ #' @name h_response_biomarkers_subgroups |
||
| 145 | +25 |
- #' count_cumulative(+ NULL |
||
| 146 | +26 |
- #' vars = "AGE",+ |
||
| 147 | +27 |
- #' thresholds = c(40, 60)+ #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list |
||
| 148 | +28 |
- #' ) %>%+ #' to the "logistic regression" variable list. The reason is that currently there is an |
||
| 149 | +29 |
- #' build_table(tern_ex_adsl)+ #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`. |
||
| 150 | +30 |
#' |
||
| 151 | +31 |
- #' @export+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
||
| 152 | +32 |
- #' @order 2+ #' |
||
| 153 | +33 |
- count_cumulative <- function(lyt,+ #' @return |
||
| 154 | +34 |
- vars,+ #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`. |
||
| 155 | +35 |
- thresholds,+ #' |
||
| 156 | +36 |
- lower_tail = TRUE,+ #' @examples |
||
| 157 | +37 |
- include_eq = TRUE,+ #' # This is how the variable list is converted internally. |
||
| 158 | +38 |
- var_labels = vars,+ #' h_rsp_to_logistic_variables( |
||
| 159 | +39 |
- show_labels = "visible",+ #' variables = list( |
||
| 160 | +40 |
- na_str = default_na_str(),+ #' rsp = "RSP", |
||
| 161 | +41 |
- nested = TRUE,+ #' covariates = c("A", "B"),
|
||
| 162 | +42 |
- ...,+ #' strata = "D" |
||
| 163 | +43 |
- table_names = vars,+ #' ), |
||
| 164 | +44 |
- .stats = NULL,+ #' biomarker = "AGE" |
||
| 165 | +45 |
- .formats = NULL,+ #' ) |
||
| 166 | +46 |
- .labels = NULL,+ #' |
||
| 167 | +47 |
- .indent_mods = NULL) {
- |
- ||
| 168 | -2x | -
- extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...)+ #' @export |
||
| 169 | +48 |
-
+ h_rsp_to_logistic_variables <- function(variables, biomarker) {
|
||
| 170 | -2x | +49 | +49x |
- afun <- make_afun(+ if ("strat" %in% names(variables)) {
|
| 171 | -2x | +|||
| 50 | +! |
- a_count_cumulative,+ warning( |
||
| 172 | -2x | +|||
| 51 | +! |
- .stats = .stats,+ "Warning: the `strat` element name of the `variables` list argument to `h_rsp_to_logistic_variables() ", |
||
| 173 | -2x | +|||
| 52 | +! |
- .formats = .formats,+ "was deprecated in tern 0.9.3.\n ", |
||
| 174 | -2x | +|||
| 53 | +! |
- .labels = .labels,+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 175 | -2x | +|||
| 54 | +
- .indent_mods = .indent_mods,+ ) |
|||
| 176 | -2x | +|||
| 55 | +! |
- .ungroup_stats = "count_fraction"+ variables[["strata"]] <- variables[["strat"]] |
||
| 177 | +56 |
- )+ } |
||
| 178 | -2x | +57 | +49x |
- analyze(+ checkmate::assert_list(variables) |
| 179 | -2x | +58 | +49x |
- lyt,+ checkmate::assert_string(variables$rsp) |
| 180 | -2x | +59 | +49x |
- vars,+ checkmate::assert_string(biomarker) |
| 181 | -2x | +60 | +49x |
- afun = afun,+ list( |
| 182 | -2x | +61 | +49x |
- na_str = na_str,+ response = variables$rsp, |
| 183 | -2x | +62 | +49x |
- table_names = table_names,+ arm = biomarker, |
| 184 | -2x | +63 | +49x |
- var_labels = var_labels,+ covariates = variables$covariates, |
| 185 | -2x | +64 | +49x |
- show_labels = show_labels,+ strata = variables$strata |
| 186 | -2x | +|||
| 65 | +
- nested = nested,+ ) |
|||
| 187 | -2x | +|||
| 66 | +
- extra_args = extra_args+ } |
|||
| 188 | +67 |
- )+ |
||
| 189 | +68 |
- }+ #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and |
| 1 | +69 |
- #' Number of Patients+ #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple |
||
| 2 | +70 |
- #'+ #' biomarkers in a given single data set. |
||
| 3 | +71 |
- #' @description `r lifecycle::badge("stable")`
+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
||
| 4 | +72 |
- #'+ #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates` |
||
| 5 | +73 |
- #' Count the number of unique and non-unique patients in a column (variable).+ #' and `strata`. |
||
| 6 | +74 |
#' |
||
| 7 | +75 |
- #' @inheritParams argument_convention+ #' @return |
||
| 8 | +76 |
- #' @param count_by (`vector`)\cr optional vector of any type to be combined with `x` when counting `nonunique`+ #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
||
| 9 | +77 |
- #' records.+ #' |
||
| 10 | +78 |
- #' @param unique_count_suffix (`logical`)\cr should `"(n)"` suffix be added to `unique_count` labels.+ #' @examples |
||
| 11 | +79 |
- #' Defaults to `TRUE`.+ #' # For a single population, estimate separately the effects |
||
| 12 | +80 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_num_patients")`
+ #' # of two biomarkers. |
||
| 13 | +81 |
- #' to see available statistics for this function.+ #' df <- h_logistic_mult_cont_df( |
||
| 14 | +82 |
- #'+ #' variables = list( |
||
| 15 | +83 |
- #' @name summarize_num_patients+ #' rsp = "rsp", |
||
| 16 | +84 |
- #' @order 1+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 17 | +85 |
- NULL+ #' covariates = "SEX" |
||
| 18 | +86 |
-
+ #' ), |
||
| 19 | +87 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of+ #' data = adrs_f |
||
| 20 | +88 |
- #' unique patients, the corresponding percentage taken with respect to the+ #' ) |
||
| 21 | +89 |
- #' total number of patients, and the number of non-unique patients.+ #' df |
||
| 22 | +90 |
#' |
||
| 23 | +91 |
- #' @param x (`character` or `factor`)\cr vector of patient IDs.+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
||
| 24 | +92 |
- #'+ #' h_coxreg_mult_cont_df( |
||
| 25 | +93 |
- #' @return+ #' variables = list( |
||
| 26 | +94 |
- #' * `s_num_patients()` returns a named `list` of 3 statistics:+ #' rsp = "rsp", |
||
| 27 | +95 |
- #' * `unique`: Vector of counts and percentages.+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 28 | +96 |
- #' * `nonunique`: Vector of counts.+ #' covariates = "SEX", |
||
| 29 | +97 |
- #' * `unique_count`: Counts.+ #' strata = "STRATA1" |
||
| 30 | +98 |
- #'+ #' ), |
||
| 31 | +99 |
- #' @examples+ #' data = adrs_f[NULL, ] |
||
| 32 | +100 |
- #' # Use the statistics function to count number of unique and nonunique patients.+ #' ) |
||
| 33 | +101 |
- #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L)+ #' |
||
| 34 | +102 |
- #' s_num_patients(+ #' @export |
||
| 35 | +103 |
- #' x = as.character(c(1, 1, 1, 2, 4, NA)),+ h_logistic_mult_cont_df <- function(variables, |
||
| 36 | +104 |
- #' labelstr = "",+ data, |
||
| 37 | +105 |
- #' .N_col = 6L,+ control = control_logistic()) {
+ |
+ ||
| 106 | +28x | +
+ if ("strat" %in% names(variables)) {
+ |
+ ||
| 107 | +! | +
+ warning(+ |
+ ||
| 108 | +! | +
+ "Warning: the `strat` element name of the `variables` list argument to `h_logistic_mult_cont_df() ",+ |
+ ||
| 109 | +! | +
+ "was deprecated in tern 0.9.3.\n ",+ |
+ ||
| 110 | +! | +
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 38 | +111 |
- #' count_by = c(1, 1, 2, 1, 1, 1)+ )+ |
+ ||
| 112 | +! | +
+ variables[["strata"]] <- variables[["strat"]] |
||
| 39 | +113 |
- #' )+ }+ |
+ ||
| 114 | +28x | +
+ assert_df_with_variables(data, variables) |
||
| 40 | +115 |
- #'+ + |
+ ||
| 116 | +28x | +
+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ |
+ ||
| 117 | +28x | +
+ checkmate::assert_list(control, names = "named") |
||
| 41 | +118 |
- #' @export+ + |
+ ||
| 119 | +28x | +
+ conf_level <- control[["conf_level"]]+ |
+ ||
| 120 | +28x | +
+ pval_label <- "p-value (Wald)" |
||
| 42 | +121 |
- s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
+
|
||
| 43 | +122 |
-
+ # If there is any data, run model, otherwise return empty results. |
||
| 44 | -109x | +123 | +28x |
- checkmate::assert_string(labelstr)+ if (nrow(data) > 0) {
|
| 45 | -109x | +124 | +27x |
- checkmate::assert_count(.N_col)+ bm_cols <- match(variables$biomarkers, names(data)) |
| 46 | -109x | +125 | +27x |
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ l_result <- lapply(variables$biomarkers, function(bm) {
|
| 47 | -109x | +126 | +48x |
- checkmate::assert_flag(unique_count_suffix)+ model_fit <- fit_logistic(+ |
+
| 127 | +48x | +
+ variables = h_rsp_to_logistic_variables(variables, bm),+ |
+ ||
| 128 | +48x | +
+ data = data,+ |
+ ||
| 129 | +48x | +
+ response_definition = control$response_definition |
||
| 48 | +130 |
-
+ ) |
||
| 49 | -109x | +131 | +48x |
- count1 <- n_available(unique(x))+ result <- h_logistic_simple_terms( |
| 50 | -109x | +132 | +48x |
- count2 <- n_available(x)+ x = bm,+ |
+
| 133 | +48x | +
+ fit_glm = model_fit,+ |
+ ||
| 134 | +48x | +
+ conf_level = control$conf_level |
||
| 51 | +135 |
-
+ ) |
||
| 52 | -109x | +136 | +48x |
- if (!is.null(count_by)) {
+ resp_vector <- if (inherits(model_fit, "glm")) {
|
| 53 | -10x | +137 | +38x |
- checkmate::assert_vector(count_by, len = length(x))+ model_fit$model[[variables$rsp]]+ |
+
| 138 | ++ |
+ } else {
|
||
| 54 | +139 | 10x |
- count2 <- n_available(unique(interaction(x, count_by)))+ as.logical(as.matrix(model_fit$y)[, "status"]) |
|
| 55 | +140 |
- }+ }+ |
+ ||
| 141 | +48x | +
+ data.frame( |
||
| 56 | +142 |
-
+ # Dummy column needed downstream to create a nested header. |
||
| 57 | -109x | +143 | +48x |
- out <- list(+ biomarker = bm, |
| 58 | -109x | +144 | +48x |
- unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr),+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE), |
| 59 | -109x | +145 | +48x |
- nonunique = formatters::with_label(count2, labelstr),+ n_tot = length(resp_vector), |
| 60 | -109x | +146 | +48x |
- unique_count = formatters::with_label(+ n_rsp = sum(resp_vector), |
| 61 | -109x | +147 | +48x |
- count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr)+ prop = mean(resp_vector), |
| 62 | -+ | |||
| 148 | +48x |
- )+ or = as.numeric(result[1L, "odds_ratio"]), |
||
| 63 | -+ | |||
| 149 | +48x |
- )+ lcl = as.numeric(result[1L, "lcl"]), |
||
| 64 | -+ | |||
| 150 | +48x |
-
+ ucl = as.numeric(result[1L, "ucl"]), |
||
| 65 | -109x | +151 | +48x |
- out+ conf_level = conf_level, |
| 66 | -+ | |||
| 152 | +48x |
- }+ pval = as.numeric(result[1L, "pvalue"]), |
||
| 67 | -+ | |||
| 153 | +48x |
-
+ pval_label = pval_label, |
||
| 68 | -+ | |||
| 154 | +48x |
- #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients+ stringsAsFactors = FALSE |
||
| 69 | +155 |
- #' in a column (variable), the corresponding percentage taken with respect to the total number of+ ) |
||
| 70 | +156 |
- #' patients, and the number of non-unique patients in the column.+ }) |
||
| 71 | -+ | |||
| 157 | +27x |
- #'+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 72 | +158 |
- #' @param required (`character` or `NULL`)\cr optional name of a variable that is required to be non-missing.+ } else {
|
||
| 73 | -+ | |||
| 159 | +1x |
- #'+ data.frame( |
||
| 74 | -+ | |||
| 160 | +1x |
- #' @return+ biomarker = variables$biomarkers, |
||
| 75 | -+ | |||
| 161 | +1x |
- #' * `s_num_patients_content()` returns the same values as `s_num_patients()`.+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE), |
||
| 76 | -+ | |||
| 162 | +1x |
- #'+ n_tot = 0L,+ |
+ ||
| 163 | +1x | +
+ n_rsp = 0L,+ |
+ ||
| 164 | +1x | +
+ prop = NA,+ |
+ ||
| 165 | +1x | +
+ or = NA,+ |
+ ||
| 166 | +1x | +
+ lcl = NA,+ |
+ ||
| 167 | +1x | +
+ ucl = NA,+ |
+ ||
| 168 | +1x | +
+ conf_level = conf_level,+ |
+ ||
| 169 | +1x | +
+ pval = NA,+ |
+ ||
| 170 | +1x | +
+ pval_label = pval_label,+ |
+ ||
| 171 | +1x | +
+ row.names = seq_along(variables$biomarkers),+ |
+ ||
| 172 | +1x | +
+ stringsAsFactors = FALSE |
||
| 77 | +173 |
- #' @examples+ ) |
||
| 78 | +174 |
- #' # Count number of unique and non-unique patients.+ } |
||
| 79 | +175 |
- #'+ } |
||
| 80 | +176 |
- #' df <- data.frame(+ |
||
| 81 | +177 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ #' @describeIn h_response_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing |
||
| 82 | +178 |
- #' EVENT = as.character(c(10, 15, 10, 17, 8))+ #' the results for a single biomarker. |
||
| 83 | +179 |
- #' )+ #' |
||
| 84 | +180 |
- #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID")+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 85 | +181 |
- #'+ #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are |
||
| 86 | +182 |
- #' df_by_event <- data.frame(+ #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()], |
||
| 87 | +183 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ #' see the example). |
||
| 88 | +184 |
- #' EVENT = c(10, 15, 10, 17, 8)+ #' |
||
| 89 | +185 |
- #' )+ #' @return |
||
| 90 | +186 |
- #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT")+ #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
||
| 91 | +187 |
#' |
||
| 92 | +188 |
- #' @export+ #' @examples |
||
| 93 | +189 |
- s_num_patients_content <- function(df,+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
||
| 94 | +190 |
- labelstr = "",+ #' df1 <- df[1, ] |
||
| 95 | +191 |
- .N_col, # nolint+ #' df1$subgroup <- "All patients" |
||
| 96 | +192 |
- .var,+ #' df1$row_type <- "content" |
||
| 97 | +193 |
- required = NULL,+ #' df1$var <- "ALL" |
||
| 98 | +194 |
- count_by = NULL,+ #' df1$var_label <- "All patients" |
||
| 99 | +195 |
- unique_count_suffix = TRUE) {
+ #' |
||
| 100 | -46x | +|||
| 196 | +
- checkmate::assert_string(.var)+ #' h_tab_rsp_one_biomarker( |
|||
| 101 | -46x | +|||
| 197 | +
- checkmate::assert_data_frame(df)+ #' df1, |
|||
| 102 | -46x | +|||
| 198 | +
- if (is.null(count_by)) {
+ #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
|
|||
| 103 | -43x | +|||
| 199 | +
- assert_df_with_variables(df, list(id = .var))+ #' ) |
|||
| 104 | +200 |
- } else {
+ #' |
||
| 105 | -3x | +|||
| 201 | +
- assert_df_with_variables(df, list(id = .var, count_by = count_by))+ #' @export |
|||
| 106 | +202 |
- }+ h_tab_rsp_one_biomarker <- function(df, |
||
| 107 | -46x | +|||
| 203 | +
- if (!is.null(required)) {
+ vars, |
|||
| 108 | -! | +|||
| 204 | +
- checkmate::assert_string(required)+ na_str = default_na_str(), |
|||
| 109 | -! | +|||
| 205 | +
- assert_df_with_variables(df, list(required = required))+ .indent_mods = 0L) {
|
|||
| 110 | -! | +|||
| 206 | +8x |
- df <- df[!is.na(df[[required]]), , drop = FALSE]+ afuns <- a_response_subgroups(na_str = na_str)[vars] |
||
| 111 | -+ | |||
| 207 | +8x |
- }+ colvars <- d_rsp_subgroups_colvars( |
||
| 112 | -+ | |||
| 208 | +8x |
-
+ vars, |
||
| 113 | -46x | +209 | +8x |
- x <- df[[.var]]+ conf_level = df$conf_level[1], |
| 114 | -46x | +210 | +8x |
- y <- if (is.null(count_by)) NULL else df[[count_by]]+ method = df$pval_label[1] |
| 115 | +211 |
-
+ ) |
||
| 116 | -46x | +212 | +8x |
- s_num_patients(+ h_tab_one_biomarker( |
| 117 | -46x | +213 | +8x |
- x = x,+ df = df, |
| 118 | -46x | +214 | +8x |
- labelstr = labelstr,+ afuns = afuns, |
| 119 | -46x | +215 | +8x |
- .N_col = .N_col,+ colvars = colvars, |
| 120 | -46x | +216 | +8x |
- count_by = y,+ na_str = na_str, |
| 121 | -46x | +217 | +8x |
- unique_count_suffix = unique_count_suffix+ .indent_mods = .indent_mods |
| 122 | +218 |
) |
||
| 123 | +219 |
} |
| 124 | +1 |
-
+ #' Custom Split Functions |
||
| 125 | +2 |
- c_num_patients <- make_afun(+ #' |
||
| 126 | +3 |
- s_num_patients_content,+ #' @description `r lifecycle::badge("stable")`
|
||
| 127 | +4 |
- .stats = c("unique", "nonunique", "unique_count"),
+ #' |
||
| 128 | +5 |
- .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx")+ #' Collection of useful functions that are expanding on the core list of functions |
||
| 129 | +6 |
- )+ #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()] |
||
| 130 | +7 |
-
+ #' for more information on how to make a custom split function. All these functions |
||
| 131 | +8 |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ #' work with [split_rows_by()] argument `split_fun` to modify the way the split |
||
| 132 | +9 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' happens. For other split functions, consider consulting [`rtables::split_funcs`]. |
||
| 133 | +10 |
#' |
||
| 134 | +11 |
- #' @return+ #' @seealso [rtables::make_split_fun()] |
||
| 135 | +12 |
- #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 136 | +13 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @name utils_split_funs |
||
| 137 | +14 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ NULL |
||
| 138 | +15 |
- #'+ |
||
| 139 | +16 |
- #' @export+ #' @describeIn utils_split_funs split function to place reference group facet at a specific position |
||
| 140 | +17 |
- #' @order 3+ #' during post-processing stage. |
||
| 141 | +18 |
- summarize_num_patients <- function(lyt,+ #' |
||
| 142 | +19 |
- var,+ #' @param position (`string` or `integer`)\cr should it be `"first"` or `"last"` or in a specific position? |
||
| 143 | +20 |
- required = NULL,+ #' |
||
| 144 | +21 |
- count_by = NULL,+ #' @return |
||
| 145 | +22 |
- unique_count_suffix = TRUE,+ #' * `ref_group_position` returns an utility function that puts the reference group |
||
| 146 | +23 |
- na_str = default_na_str(),+ #' as first, last or at a certain position and needs to be assigned to `split_fun`. |
||
| 147 | +24 |
- .stats = NULL,+ #' |
||
| 148 | +25 |
- .formats = NULL,+ #' @examples |
||
| 149 | +26 |
- .labels = c(+ #' library(dplyr) |
||
| 150 | +27 |
- unique = "Number of patients with at least one event",+ #' |
||
| 151 | +28 |
- nonunique = "Number of events"+ #' dat <- data.frame( |
||
| 152 | +29 |
- ),+ #' x = factor(letters[1:5], levels = letters[5:1]), |
||
| 153 | +30 |
- indent_mod = lifecycle::deprecated(),+ #' y = 1:5 |
||
| 154 | +31 |
- .indent_mods = 0L,+ #' ) |
||
| 155 | +32 |
- riskdiff = FALSE,+ #' |
||
| 156 | +33 |
- ...) {
+ #' # With rtables layout functions |
||
| 157 | -9x | +|||
| 34 | +
- checkmate::assert_flag(riskdiff)+ #' basic_table() %>% |
|||
| 158 | +35 |
-
+ #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
|
||
| 159 | -9x | +|||
| 36 | +
- if (lifecycle::is_present(indent_mod)) {
+ #' analyze("y") %>%
|
|||
| 160 | -! | +|||
| 37 | +
- lifecycle::deprecate_warn("0.8.2", "summarize_num_patients(indent_mod)", "summarize_num_patients(.indent_mods)")
+ #' build_table(dat) |
|||
| 161 | -! | +|||
| 38 | +
- .indent_mods <- indent_mod+ #' |
|||
| 162 | +39 |
- }+ #' # With tern layout funcitons |
||
| 163 | +40 |
-
+ #' adtte_f <- tern_ex_adtte %>% |
||
| 164 | -4x | +|||
| 41 | +
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ #' filter(PARAMCD == "OS") %>% |
|||
| 165 | -2x | +|||
| 42 | +
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ #' mutate( |
|||
| 166 | +43 |
-
+ #' AVAL = day2month(AVAL), |
||
| 167 | -9x | +|||
| 44 | +
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ #' is_event = CNSR == 0 |
|||
| 168 | +45 |
-
+ #' ) |
||
| 169 | -9x | +|||
| 46 | +
- cfun <- make_afun(+ #' |
|||
| 170 | -9x | +|||
| 47 | +
- c_num_patients,+ #' basic_table() %>% |
|||
| 171 | -9x | +|||
| 48 | +
- .stats = .stats,+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
|
|||
| 172 | -9x | +|||
| 49 | +
- .formats = .formats,+ #' add_colcounts() %>% |
|||
| 173 | -9x | +|||
| 50 | +
- .labels = .labels+ #' surv_time( |
|||
| 174 | +51 |
- )+ #' vars = "AVAL", |
||
| 175 | +52 |
-
+ #' var_labels = "Survival Time (Months)", |
||
| 176 | -9x | +|||
| 53 | +
- extra_args <- if (isFALSE(riskdiff)) {
+ #' is_event = "is_event", |
|||
| 177 | -8x | +|||
| 54 | +
- s_args+ #' ) %>% |
|||
| 178 | +55 |
- } else {
+ #' build_table(df = adtte_f) |
||
| 179 | -1x | +|||
| 56 | +
- list(+ #' |
|||
| 180 | -1x | +|||
| 57 | +
- afun = list("s_num_patients_content" = cfun),
+ #' basic_table() %>% |
|||
| 181 | -1x | +|||
| 58 | +
- .stats = .stats,+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>% |
|||
| 182 | -1x | +|||
| 59 | +
- .indent_mods = .indent_mods,+ #' add_colcounts() %>% |
|||
| 183 | -1x | +|||
| 60 | +
- s_args = s_args+ #' surv_time( |
|||
| 184 | +61 |
- )+ #' vars = "AVAL", |
||
| 185 | +62 |
- }+ #' var_labels = "Survival Time (Months)", |
||
| 186 | +63 |
-
+ #' is_event = "is_event", |
||
| 187 | -9x | +|||
| 64 | +
- summarize_row_groups(+ #' ) %>% |
|||
| 188 | -9x | +|||
| 65 | +
- lyt = lyt,+ #' build_table(df = adtte_f) |
|||
| 189 | -9x | +|||
| 66 | +
- var = var,+ #'+ |
+ |||
| 67 | ++ |
+ #' @export+ |
+ ||
| 68 | ++ |
+ ref_group_position <- function(position = "first") {
|
||
| 190 | -9x | +69 | +20x |
- cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff),+ make_split_fun( |
| 191 | -9x | +70 | +20x |
- na_str = na_str,+ post = list( |
| 192 | -9x | +71 | +20x |
- extra_args = extra_args,+ function(splret, spl, fulldf) {
|
| 193 | -9x | +72 | +57x |
- indent_mod = .indent_mods+ if (!"ref_group_value" %in% methods::slotNames(spl)) {
|
| 194 | -+ | |||
| 73 | +1x |
- )+ stop("Reference group is undefined.")
|
||
| 195 | +74 |
- }+ } |
||
| 196 | +75 | |||
| 197 | -+ | |||
| 76 | +56x |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ spl_var <- rtables:::spl_payload(spl) |
||
| 198 | -+ | |||
| 77 | +56x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ fulldf[[spl_var]] <- factor(fulldf[[spl_var]]) |
||
| 199 | -+ | |||
| 78 | +56x |
- #'+ init_lvls <- levels(fulldf[[spl_var]]) |
||
| 200 | +79 |
- #' @return+ |
||
| 201 | -+ | |||
| 80 | +56x |
- #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions,+ if (!all(names(splret$values) %in% init_lvls)) {
|
||
| 202 | -+ | |||
| 81 | +! |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ stop("This split function does not work with combination facets.")
|
||
| 203 | +82 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ } |
||
| 204 | +83 |
- #'+ |
||
| 205 | -+ | |||
| 84 | +56x |
- #' @details In general, functions that starts with `analyze*` are expected to+ ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl)) |
||
| 206 | -+ | |||
| 85 | +56x |
- #' work like [rtables::analyze()], while functions that starts with `summarize*`+ pos_choices <- c("first", "last")
|
||
| 207 | -+ | |||
| 86 | +56x |
- #' are based upon [rtables::summarize_row_groups()]. The latter provides a+ if (checkmate::test_choice(position, pos_choices) && position == "first") {
|
||
| 208 | -+ | |||
| 87 | +41x |
- #' value for each dividing split in the row and column space, but, being it+ pos <- 0 |
||
| 209 | -+ | |||
| 88 | +15x |
- #' bound to the fundamental splits, it is repeated by design in every page+ } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
|
||
| 210 | -+ | |||
| 89 | +12x |
- #' when pagination is involved.+ pos <- length(init_lvls) |
||
| 211 | -+ | |||
| 90 | +3x |
- #'+ } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
|
||
| 212 | -+ | |||
| 91 | +3x |
- #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows.+ pos <- position - 1 |
||
| 213 | +92 |
- #'+ } else {
|
||
| 214 | -+ | |||
| 93 | +! |
- #' @examples+ stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
|
||
| 215 | +94 |
- #' df <- data.frame(+ } |
||
| 216 | +95 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)),+ |
||
| 217 | -+ | |||
| 96 | +56x |
- #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
+ reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos) |
||
| 218 | -+ | |||
| 97 | +56x |
- #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17)+ ord <- match(reord_lvls, names(splret$values)) |
||
| 219 | +98 |
- #' )+ |
||
| 220 | -+ | |||
| 99 | +56x |
- #'+ make_split_result( |
||
| 221 | -+ | |||
| 100 | +56x |
- #' tbl <- basic_table() %>%+ splret$values[ord], |
||
| 222 | -+ | |||
| 101 | +56x |
- #' split_cols_by("ARM") %>%
+ splret$datasplit[ord], |
||
| 223 | -+ | |||
| 102 | +56x |
- #' add_colcounts() %>%+ splret$labels[ord] |
||
| 224 | +103 |
- #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
+ ) |
||
| 225 | +104 |
- #' build_table(df)+ } |
||
| 226 | +105 |
- #'+ ) |
||
| 227 | +106 |
- #' tbl+ ) |
||
| 228 | +107 |
- #'+ } |
||
| 229 | +108 |
- #' @export+ |
||
| 230 | +109 |
- #' @order 2+ #' @describeIn utils_split_funs split function to change level order based on a `integer` |
||
| 231 | +110 |
- analyze_num_patients <- function(lyt,+ #' vector or a `character` vector that represent the split variable's factor levels. |
||
| 232 | +111 |
- vars,+ #' |
||
| 233 | +112 |
- required = NULL,+ #' @param order (`character` or `integer`)\cr vector of ordering indexes for the split facets. |
||
| 234 | +113 |
- count_by = NULL,+ #' |
||
| 235 | +114 |
- unique_count_suffix = TRUE,+ #' @return |
||
| 236 | +115 |
- na_str = default_na_str(),+ #' * `level_order` returns an utility function that changes the original levels' order, |
||
| 237 | +116 |
- nested = TRUE,+ #' depending on input `order` and split levels. |
||
| 238 | +117 |
- .stats = NULL,+ #' |
||
| 239 | +118 |
- .formats = NULL,+ #' @examples |
||
| 240 | +119 |
- .labels = c(+ #' # level_order -------- |
||
| 241 | +120 |
- unique = "Number of patients with at least one event",+ #' # Even if default would bring ref_group first, the original order puts it last |
||
| 242 | +121 |
- nonunique = "Number of events"+ #' basic_table() %>% |
||
| 243 | +122 |
- ),+ #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
|
||
| 244 | +123 |
- show_labels = c("default", "visible", "hidden"),
+ #' analyze("Sepal.Length") %>%
|
||
| 245 | +124 |
- indent_mod = lifecycle::deprecated(),+ #' build_table(iris) |
||
| 246 | +125 |
- .indent_mods = 0L,+ #' |
||
| 247 | +126 |
- riskdiff = FALSE,+ #' # character vector |
||
| 248 | +127 |
- ...) {
- |
- ||
| 249 | -3x | -
- checkmate::assert_flag(riskdiff)+ #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)]) |
||
| 250 | +128 | - - | -||
| 251 | -3x | -
- if (lifecycle::is_present(indent_mod)) {
- |
- ||
| 252 | -! | -
- lifecycle::deprecate_warn("0.8.2", "analyze_num_patients(indent_mod)", "analyze_num_patients(.indent_mods)")
- |
- ||
| 253 | -! | -
- .indent_mods <- indent_mod+ #' basic_table() %>% |
||
| 254 | +129 |
- }+ #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
|
||
| 255 | +130 | - - | -||
| 256 | -! | -
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
- |
- ||
| 257 | -! | -
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ #' analyze("Sepal.Length") %>%
|
||
| 258 | +131 | - - | -||
| 259 | -3x | -
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ #' build_table(iris) |
||
| 260 | +132 | - - | -||
| 261 | -3x | -
- afun <- make_afun(- |
- ||
| 262 | -3x | -
- c_num_patients,- |
- ||
| 263 | -3x | -
- .stats = .stats,- |
- ||
| 264 | -3x | -
- .formats = .formats,- |
- ||
| 265 | -3x | -
- .labels = .labels+ #' |
||
| 266 | +133 |
- )+ #' @export |
||
| 267 | +134 | - - | -||
| 268 | -3x | -
- extra_args <- if (isFALSE(riskdiff)) {
+ level_order <- function(order) {
|
||
| 269 | +135 | 2x |
- s_args- |
- |
| 270 | -- |
- } else {
+ make_split_fun( |
||
| 271 | -1x | +136 | +2x |
- list(+ post = list( |
| 272 | -1x | +137 | +2x |
- afun = list("s_num_patients_content" = afun),
+ function(splret, spl, fulldf) {
|
| 273 | -1x | +138 | +4x |
- .stats = .stats,+ if (checkmate::test_integerish(order)) {
|
| 274 | +139 | 1x |
- .indent_mods = .indent_mods,+ checkmate::assert_integerish(order, lower = 1, upper = length(splret$values)) |
|
| 275 | +140 | 1x |
- s_args = s_args+ ord <- order |
|
| 276 | +141 |
- )+ } else {
|
||
| 277 | -+ | |||
| 142 | +3x |
- }+ checkmate::assert_character(order, len = length(splret$values)) |
||
| 278 | -+ | |||
| 143 | +3x |
-
+ checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE) |
||
| 279 | +144 | 3x |
- analyze(+ ord <- match(order, names(splret$values)) |
|
| 280 | -3x | +|||
| 145 | +
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ } |
|||
| 281 | -3x | +146 | +4x |
- lyt = lyt,+ make_split_result( |
| 282 | -3x | +147 | +4x |
- vars = vars,+ splret$values[ord], |
| 283 | -3x | +148 | +4x |
- na_str = na_str,+ splret$datasplit[ord], |
| 284 | -3x | +149 | +4x |
- nested = nested,+ splret$labels[ord] |
| 285 | -3x | +|||
| 150 | +
- extra_args = extra_args,+ ) |
|||
| 286 | -3x | +|||
| 151 | +
- show_labels = show_labels,+ } |
|||
| 287 | -3x | +|||
| 152 | +
- indent_mod = .indent_mods+ ) |
|||
| 288 | +153 |
) |
||
| 289 | +154 |
} |