| 1 |
- #' Control functions for Kaplan-Meier plot annotation tables+ #' Formatting functions |
|||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' See below for the list of formatting functions created in `tern` to work with `rtables`. |
|||
| 5 |
- #' Auxiliary functions for controlling arguments for formatting the annotation tables that can be added to plots+ #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional |
|||
| 6 |
- #' generated via [g_km()].+ #' custom formats can be created via the [`formatters::sprintf_format()`] function. |
|||
| 8 |
- #' @param x (`proportion`)\cr x-coordinate for center of annotation table.+ #' @family formatting functions |
|||
| 9 |
- #' @param y (`proportion`)\cr y-coordinate for center of annotation table.+ #' @name formatting_functions |
|||
| 10 |
- #' @param w (`proportion`)\cr relative width of the annotation table.+ NULL |
|||
| 11 |
- #' @param h (`proportion`)\cr relative height of the annotation table.+ |
|||
| 12 |
- #' @param fill (`flag` or `character`)\cr whether the annotation table should have a background fill color.+ #' Format fraction and percentage |
|||
| 13 |
- #' Can also be a color code to use as the background fill color. If `TRUE`, color code defaults to `"#00000020"`.+ #' |
|||
| 14 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|||
| 15 |
- #' @return A list of components with the same names as the arguments.+ #' |
|||
| 16 |
- #'+ #' Formats a fraction together with ratio in percent. |
|||
| 17 |
- #' @seealso [g_km()]+ #' |
|||
| 18 |
- #'+ #' @param x (named `integer`)\cr vector with elements `num` and `denom`. |
|||
| 19 |
- #' @name control_annot+ #' @param ... not used. Required for `rtables` interface. |
|||
| 20 |
- NULL+ #' |
|||
| 21 |
-
+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
|||
| 22 |
- #' @describeIn control_annot Control function for formatting the median survival time annotation table. This annotation+ #' |
|||
| 23 |
- #' table can be added in [g_km()] by setting `annot_surv_med=TRUE`, and can be configured using the+ #' @examples |
|||
| 24 |
- #' `control_surv_med_annot()` function by setting it as the `control_annot_surv_med` argument.+ #' format_fraction(x = c(num = 2L, denom = 3L)) |
|||
| 25 |
- #'+ #' format_fraction(x = c(num = 0L, denom = 3L)) |
|||
| 26 |
- #' @examples+ #' |
|||
| 27 |
- #' control_surv_med_annot()+ #' @family formatting functions |
|||
| 28 |
- #'+ #' @export |
|||
| 29 |
- #' @export+ format_fraction <- function(x, ...) {
|
|||
| 30 | -+ | 4x |
- control_surv_med_annot <- function(x = 0.8, y = 0.85, w = 0.32, h = 0.16, fill = TRUE) {
+ attr(x, "label") <- NULL |
|
| 31 | -22x | +
- assert_proportion_value(x)+ |
||
| 32 | -22x | +4x |
- assert_proportion_value(y)+ checkmate::assert_vector(x) |
|
| 33 | -22x | +4x |
- assert_proportion_value(w)+ checkmate::assert_count(x["num"]) |
|
| 34 | -22x | +2x |
- assert_proportion_value(h)+ checkmate::assert_count(x["denom"]) |
|
| 36 | -22x | +2x |
- list(x = x, y = y, w = w, h = h, fill = fill)+ result <- if (x["num"] == 0) {
|
|
| 37 | -+ | 1x |
- }+ paste0(x["num"], "/", x["denom"]) |
|
| 38 |
-
+ } else {
|
|||
| 39 | -+ | 1x |
- #' @describeIn control_annot Control function for formatting the Cox-PH annotation table. This annotation table can be+ paste0( |
|
| 40 | -+ | 1x |
- #' added in [g_km()] by setting `annot_coxph=TRUE`, and can be configured using the `control_coxph_annot()` function+ x["num"], "/", x["denom"], |
|
| 41 | -+ | 1x |
- #' by setting it as the `control_annot_coxph` argument.+ " (", round(x["num"] / x["denom"] * 100, 1), "%)"
|
|
| 42 |
- #'+ ) |
|||
| 43 |
- #' @param ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the+ } |
|||
| 44 |
- #' annotation table. If `FALSE` (default), only comparison groups will be printed in the table labels.+ |
|||
| 45 | -+ | 2x |
- #'+ return(result) |
|
| 46 |
- #' @examples+ } |
|||
| 47 |
- #' control_coxph_annot()+ |
|||
| 48 |
- #'+ #' Format fraction and percentage with fixed single decimal place |
|||
| 49 |
- #' @export+ #' |
|||
| 50 |
- control_coxph_annot <- function(x = 0.29, y = 0.51, w = 0.4, h = 0.125, fill = TRUE, ref_lbls = FALSE) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 51 | -11x | +
- checkmate::assert_logical(ref_lbls, any.missing = FALSE)+ #' |
||
| 52 |
-
+ #' Formats a fraction together with ratio in percent with fixed single decimal place. |
|||
| 53 | -11x | +
- res <- c(control_surv_med_annot(x = x, y = y, w = w, h = h), list(ref_lbls = ref_lbls))+ #' Includes trailing zero in case of whole number percentages to always keep one decimal place. |
||
| 54 | -11x | +
- res+ #' |
||
| 55 |
- }+ #' @inheritParams format_fraction |
|||
| 56 |
-
+ #' |
|||
| 57 |
- #' Helper function to calculate x-tick positions+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
|||
| 59 |
- #' @description `r lifecycle::badge("stable")`
+ #' @examples |
|||
| 60 |
- #'+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L)) |
|||
| 61 |
- #' Calculate the positions of ticks on the x-axis. However, if `xticks` already+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L)) |
|||
| 62 |
- #' exists it is kept as is. It is based on the same function `ggplot2` relies on,+ #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L)) |
|||
| 63 |
- #' and is required in the graphic and the patient-at-risk annotation table.+ #' |
|||
| 64 |
- #'+ #' @family formatting functions |
|||
| 65 |
- #' @inheritParams g_km+ #' @export |
|||
| 66 |
- #' @inheritParams h_ggkm+ format_fraction_fixed_dp <- function(x, ...) {
|
|||
| 67 | -+ | 3x |
- #'+ attr(x, "label") <- NULL |
|
| 68 | -+ | 3x |
- #' @return A vector of positions to use for x-axis ticks on a `ggplot` object.+ checkmate::assert_vector(x) |
|
| 69 | -+ | 3x |
- #'+ checkmate::assert_count(x["num"]) |
|
| 70 | -+ | 3x |
- #' @examples+ checkmate::assert_count(x["denom"]) |
|
| 71 |
- #' library(dplyr)+ |
|||
| 72 | -+ | 3x |
- #' library(survival)+ result <- if (x["num"] == 0) {
|
|
| 73 | -+ | 1x |
- #'+ paste0(x["num"], "/", x["denom"]) |
|
| 74 |
- #' data <- tern_ex_adtte %>%+ } else {
|
|||
| 75 | -+ | 2x |
- #' filter(PARAMCD == "OS") %>%+ paste0( |
|
| 76 | -+ | 2x |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ x["num"], "/", x["denom"], |
|
| 77 | -+ | 2x |
- #' h_data_plot()+ " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
|
|
| 78 |
- #'+ ) |
|||
| 79 |
- #' h_xticks(data)+ } |
|||
| 80 | -+ | 3x |
- #' h_xticks(data, xticks = seq(0, 3000, 500))+ return(result) |
|
| 81 |
- #' h_xticks(data, xticks = 500)+ } |
|||
| 82 |
- #' h_xticks(data, xticks = 500, max_time = 6000)+ |
|||
| 83 |
- #' h_xticks(data, xticks = c(0, 500), max_time = 300)+ #' Format count and fraction |
|||
| 84 |
- #' h_xticks(data, xticks = 500, max_time = 300)+ #' |
|||
| 85 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|||
| 86 |
- #' @export+ #' |
|||
| 87 |
- h_xticks <- function(data, xticks = NULL, max_time = NULL) {
+ #' Formats a count together with fraction with special consideration when count is `0`. |
|||
| 88 | -18x | +
- if (is.null(xticks)) {
+ #' |
||
| 89 | -13x | +
- if (is.null(max_time)) {
+ #' @param x (`numeric(2)`)\cr vector of length 2 with count and fraction, respectively. |
||
| 90 | -11x | +
- labeling::extended(range(data$time)[1], range(data$time)[2], m = 5)+ #' @param ... not used. Required for `rtables` interface. |
||
| 91 |
- } else {
+ #' |
|||
| 92 | -2x | +
- labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5)+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
||
| 93 |
- }+ #' |
|||
| 94 | -5x | +
- } else if (checkmate::test_number(xticks)) {
+ #' @examples |
||
| 95 | -2x | +
- if (is.null(max_time)) {
+ #' format_count_fraction(x = c(2, 0.6667)) |
||
| 96 | -1x | +
- seq(0, max(data$time), xticks)+ #' format_count_fraction(x = c(0, 0)) |
||
| 97 |
- } else {
+ #' |
|||
| 98 | -1x | +
- seq(0, max(data$time, max_time), xticks)+ #' @family formatting functions |
||
| 99 |
- }+ #' @export |
|||
| 100 | -3x | +
- } else if (is.numeric(xticks)) {
+ format_count_fraction <- function(x, ...) {
|
||
| 101 | -2x | +3x |
- xticks+ attr(x, "label") <- NULL |
|
| 102 |
- } else {
+
|
|||
| 103 | -1x | +3x |
- stop(+ if (any(is.na(x))) {
|
|
| 104 | 1x |
- paste(+ return("NA")
|
||
| 105 | -1x | +
- "xticks should be either `NULL`",+ } |
||
| 106 | -1x | +
- "or a single number (interval between x ticks)",+ |
||
| 107 | -1x | +2x |
- "or a numeric vector (position of ticks on the x axis)"+ checkmate::assert_vector(x) |
|
| 108 | -+ | 2x |
- )+ checkmate::assert_integerish(x[1]) |
|
| 109 | -+ | 2x |
- )+ assert_proportion_value(x[2], include_boundaries = TRUE) |
|
| 110 |
- }+ |
|||
| 111 | -+ | 2x |
- }+ result <- if (x[1] == 0) {
|
|
| 112 | -+ | 1x |
-
+ "0" |
|
| 113 |
- #' Helper function for survival estimations+ } else {
|
|||
| 114 | -+ | 1x |
- #'+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
|
| 115 |
- #' @description `r lifecycle::badge("stable")`
+ } |
|||
| 116 |
- #'+ |
|||
| 117 | -+ | 2x |
- #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval.+ return(result) |
|
| 118 |
- #'+ } |
|||
| 119 |
- #' @inheritParams h_data_plot+ |
|||
| 120 |
- #'+ #' Format count and percentage with fixed single decimal place |
|||
| 121 |
- #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ #' |
|||
| 122 |
- #'+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 123 |
- #' @examples+ #' |
|||
| 124 |
- #' library(dplyr)+ #' Formats a count together with fraction with special consideration when count is `0`. |
|||
| 125 |
- #' library(survival)+ #' |
|||
| 126 |
- #'+ #' @inheritParams format_count_fraction |
|||
| 127 |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS")+ #' |
|||
| 128 |
- #' fit <- survfit(+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
|||
| 129 |
- #' formula = Surv(AVAL, 1 - CNSR) ~ ARMCD,+ #' |
|||
| 130 |
- #' data = adtte+ #' @examples |
|||
| 131 |
- #' )+ #' format_count_fraction_fixed_dp(x = c(2, 0.6667)) |
|||
| 132 |
- #' h_tbl_median_surv(fit_km = fit)+ #' format_count_fraction_fixed_dp(x = c(2, 0.5)) |
|||
| 133 |
- #'+ #' format_count_fraction_fixed_dp(x = c(0, 0)) |
|||
| 134 |
- #' @export+ #' |
|||
| 135 |
- h_tbl_median_surv <- function(fit_km, armval = "All") {
+ #' @family formatting functions |
|||
| 136 | -10x | +
- y <- if (is.null(fit_km$strata)) {
+ #' @export |
||
| 137 | -! | +
- as.data.frame(t(summary(fit_km)$table), row.names = armval)+ format_count_fraction_fixed_dp <- function(x, ...) {
|
||
| 138 | -+ | 1408x |
- } else {
+ attr(x, "label") <- NULL |
|
| 139 | -10x | +
- tbl <- summary(fit_km)$table+ |
||
| 140 | -10x | +1408x |
- rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
+ if (any(is.na(x))) {
|
|
| 141 | -10x | +! |
- rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2]+ return("NA")
|
|
| 142 | -10x | +
- as.data.frame(tbl)+ } |
||
| 143 |
- }+ |
|||
| 144 | -10x | +1408x |
- conf.int <- summary(fit_km)$conf.int # nolint+ checkmate::assert_vector(x) |
|
| 145 | -10x | +1408x |
- y$records <- round(y$records)+ checkmate::assert_integerish(x[1]) |
|
| 146 | -10x | +1408x |
- y$median <- signif(y$median, 4)+ assert_proportion_value(x[2], include_boundaries = TRUE) |
|
| 147 | -10x | +
- y$`CI` <- paste0(+ |
||
| 148 | -10x | +1408x |
- "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
+ result <- if (x[1] == 0) {
|
|
| 149 | -+ | 195x |
- )+ "0" |
|
| 150 | -10x | +1408x |
- stats::setNames(+ } else if (.is_equal_float(x[2], 1)) {
|
|
| 151 | -10x | +549x |
- y[c("records", "median", "CI")],
+ sprintf("%d (100%%)", x[1])
|
|
| 152 | -10x | +
- c("N", "Median", f_conf_level(conf.int))
+ } else {
|
||
| 153 | -+ | 664x |
- )+ sprintf("%d (%.1f%%)", x[1], x[2] * 100)
|
|
| 154 |
- }+ } |
|||
| 156 | -+ | 1408x |
- #' Helper function for generating a pairwise Cox-PH table+ return(result) |
|
| 157 |
- #'+ } |
|||
| 158 |
- #' @description `r lifecycle::badge("stable")`
+
|
|||
| 159 |
- #'+ #' Format count and fraction with special case for count < 10 |
|||
| 160 |
- #' Create a `data.frame` of pairwise stratified or unstratified Cox-PH analysis results.+ #' |
|||
| 161 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|||
| 162 |
- #' @inheritParams g_km+ #' |
|||
| 163 |
- #' @param annot_coxph_ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the+ #' Formats a count together with fraction with special consideration when count is less than 10. |
|||
| 164 |
- #' `annot_coxph` table. If `FALSE` (default), only comparison groups will be printed in `annot_coxph` table labels.+ #' |
|||
| 165 |
- #'+ #' @inheritParams format_count_fraction |
|||
| 166 |
- #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ #' |
|||
| 167 |
- #' and `p-value (log-rank)`.+ #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed. |
|||
| 170 |
- #' library(dplyr)+ #' format_count_fraction_lt10(x = c(275, 0.9673)) |
|||
| 171 |
- #'+ #' format_count_fraction_lt10(x = c(2, 0.6667)) |
|||
| 172 |
- #' adtte <- tern_ex_adtte %>%+ #' format_count_fraction_lt10(x = c(9, 1)) |
|||
| 173 |
- #' filter(PARAMCD == "OS") %>%+ #' |
|||
| 174 |
- #' mutate(is_event = CNSR == 0)+ #' @family formatting functions |
|||
| 175 |
- #'+ #' @export |
|||
| 176 |
- #' h_tbl_coxph_pairwise(+ format_count_fraction_lt10 <- function(x, ...) {
|
|||
| 177 | -+ | 7x |
- #' df = adtte,+ attr(x, "label") <- NULL |
|
| 178 |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"),+ |
|||
| 179 | -+ | 7x |
- #' control_coxph_pw = control_coxph(conf_level = 0.9)+ if (any(is.na(x))) {
|
|
| 180 | -+ | 1x |
- #' )+ return("NA")
|
|
| 181 |
- #'+ } |
|||
| 182 |
- #' @export+ |
|||
| 183 | -+ | 6x |
- h_tbl_coxph_pairwise <- function(df,+ checkmate::assert_vector(x) |
|
| 184 | -+ | 6x |
- variables,+ checkmate::assert_integerish(x[1]) |
|
| 185 | -+ | 6x |
- ref_group_coxph = NULL,+ assert_proportion_value(x[2], include_boundaries = TRUE) |
|
| 186 |
- control_coxph_pw = control_coxph(),+ |
|||
| 187 | -+ | 6x |
- annot_coxph_ref_lbls = FALSE) {
+ result <- if (x[1] < 10) {
|
|
| 188 | -4x | +3x |
- if ("strat" %in% names(variables)) {
+ paste0(x[1]) |
|
| 189 | -! | +
- warning(+ } else {
|
||
| 190 | -! | +3x |
- "Warning: the `strat` element name of the `variables` list argument to `h_tbl_coxph_pairwise() ",+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
|
| 191 | -! | +
- "was deprecated in tern 0.9.4.\n ",+ } |
||
| 192 | -! | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ |
||
| 193 | -+ | 6x |
- )+ return(result) |
|
| 194 | -! | +
- variables[["strata"]] <- variables[["strat"]]+ } |
||
| 195 |
- }+ |
|||
| 196 |
-
+ #' Format XX as a formatting function |
|||
| 197 | -4x | +
- assert_df_with_variables(df, variables)+ #' |
||
| 198 | -4x | +
- checkmate::assert_choice(ref_group_coxph, levels(df[[variables$arm]]), null.ok = TRUE)+ #' Translate a string where x and dots are interpreted as number place |
||
| 199 | -4x | +
- checkmate::assert_flag(annot_coxph_ref_lbls)+ #' holders, and others as formatting elements. |
||
| 200 |
-
+ #' |
|||
| 201 | -4x | +
- arm <- variables$arm+ #' @param str (`string`)\cr template. |
||
| 202 | -4x | +
- df[[arm]] <- factor(df[[arm]])+ #' |
||
| 203 |
-
+ #' @return An `rtables` formatting function. |
|||
| 204 | -4x | +
- ref_group <- if (!is.null(ref_group_coxph)) ref_group_coxph else levels(df[[variables$arm]])[1]+ #' |
||
| 205 | -4x | +
- comp_group <- setdiff(levels(df[[arm]]), ref_group)+ #' @examples |
||
| 206 |
-
+ #' test <- list(c(1.658, 0.5761), c(1e1, 785.6)) |
|||
| 207 | -4x | +
- results <- Map(function(comp) {
+ #' |
||
| 208 | -8x | +
- res <- s_coxph_pairwise(+ #' z <- format_xx("xx (xx.x)")
|
||
| 209 | -8x | +
- df = df[df[[arm]] == comp, , drop = FALSE],+ #' sapply(test, z) |
||
| 210 | -8x | +
- .ref_group = df[df[[arm]] == ref_group, , drop = FALSE],+ #' |
||
| 211 | -8x | +
- .in_ref_col = FALSE,+ #' z <- format_xx("xx.x - xx.x")
|
||
| 212 | -8x | +
- .var = variables$tte,+ #' sapply(test, z) |
||
| 213 | -8x | +
- is_event = variables$is_event,+ #' |
||
| 214 | -8x | +
- strata = variables$strata,+ #' z <- format_xx("xx.x, incl. xx.x% NE")
|
||
| 215 | -8x | +
- control = control_coxph_pw+ #' sapply(test, z) |
||
| 216 |
- )+ #' |
|||
| 217 | -8x | +
- res_df <- data.frame(+ #' @family formatting functions |
||
| 218 | -8x | +
- hr = format(round(res$hr, 2), nsmall = 2),+ #' @export |
||
| 219 | -8x | +
- hr_ci = paste0(+ format_xx <- function(str) {
|
||
| 220 | -8x | +
- "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
+ # Find position in the string. |
||
| 221 | -8x | +1x |
- format(round(res$hr_ci[2], 2), nsmall = 2), ")"+ positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE) |
|
| 222 | -+ | 1x |
- ),+ x_positions <- regmatches(x = str, m = positions)[[1]] |
|
| 223 | -8x | +
- pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),+ |
||
| 224 | -8x | +
- stringsAsFactors = FALSE+ # Roundings depends on the number of x behind [.]. |
||
| 225 | -+ | 1x |
- )+ roundings <- lapply( |
|
| 226 | -8x | +1x |
- colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
+ X = x_positions, |
|
| 227 | -8x | +1x |
- row.names(res_df) <- comp+ function(x) {
|
|
| 228 | -8x | +2x |
- res_df+ y <- strsplit(split = "\\.", x = x)[[1]] |
|
| 229 | -4x | +2x |
- }, comp_group)+ rounding <- function(x) {
|
|
| 230 | -1x | +4x |
- if (annot_coxph_ref_lbls) names(results) <- paste(comp_group, "vs.", ref_group)+ round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0)) |
|
| 231 |
-
+ } |
|||
| 232 | -4x | +2x |
- do.call(rbind, results)+ return(rounding) |
|
| 233 |
- }+ } |
|||
| 234 |
-
+ ) |
|||
| 235 |
- #' Helper function to tidy survival fit data+ |
|||
| 236 | -+ | 1x |
- #'+ rtable_format <- function(x, output) {
|
|
| 237 | -+ | 2x |
- #' @description `r lifecycle::badge("stable")`
+ values <- Map(y = x, fun = roundings, function(y, fun) fun(y)) |
|
| 238 | -+ | 2x |
- #'+ regmatches(x = str, m = positions)[[1]] <- values |
|
| 239 | -+ | 2x |
- #' Convert the survival fit data into a data frame designed for plotting+ return(str) |
|
| 240 |
- #' within `g_km`.+ } |
|||
| 241 |
- #'+ |
|||
| 242 | -+ | 1x |
- #' This starts from the [broom::tidy()] result, and then:+ return(rtable_format) |
|
| 243 |
- #' * Post-processes the `strata` column into a factor.+ } |
|||
| 244 |
- #' * Extends each stratum by an additional first row with time 0 and probability 1 so that+ |
|||
| 245 |
- #' downstream plot lines start at those coordinates.+ #' Format numeric values by significant figures |
|||
| 246 |
- #' * Adds a `censor` column.+ #' |
|||
| 247 |
- #' * Filters the rows before `max_time`.+ #' Format numeric values to print with a specified number of significant figures. |
|||
| 249 |
- #' @inheritParams g_km+ #' @param sigfig (`integer(1)`)\cr number of significant figures to display. |
|||
| 250 |
- #' @param fit_km (`survfit`)\cr result of [survival::survfit()].+ #' @param format (`string`)\cr the format label (string) to apply when printing the value. Decimal |
|||
| 251 |
- #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`.+ #' places in string are ignored in favor of formatting by significant figures. Formats options are: |
|||
| 252 |
- #'+ #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`. |
|||
| 253 |
- #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`,+ #' @param num_fmt (`string`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for |
|||
| 254 |
- #' `conf.low`, `strata`, and `censor`.+ #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`) |
|||
| 255 |
- #'+ #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the |
|||
| 256 |
- #' @examples+ #' [formatC()] `format` argument for more options. |
|||
| 257 |
- #' library(dplyr)+ #' |
|||
| 258 |
- #' library(survival)+ #' @return An `rtables` formatting function. |
|||
| 260 |
- #' # Test with multiple arms+ #' @examples |
|||
| 261 |
- #' tern_ex_adtte %>%+ #' fmt_3sf <- format_sigfig(3) |
|||
| 262 |
- #' filter(PARAMCD == "OS") %>%+ #' fmt_3sf(1.658) |
|||
| 263 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' fmt_3sf(1e1) |
|||
| 264 |
- #' h_data_plot()+ #' |
|||
| 265 |
- #'+ #' fmt_5sf <- format_sigfig(5) |
|||
| 266 |
- #' # Test with single arm+ #' fmt_5sf(0.57) |
|||
| 267 |
- #' tern_ex_adtte %>%+ #' fmt_5sf(0.000025645) |
|||
| 268 |
- #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>%+ #' |
|||
| 269 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' @family formatting functions |
|||
| 270 |
- #' h_data_plot(armval = "ARM B")+ #' @export |
|||
| 271 |
- #'+ format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
|
|||
| 272 | -+ | 3x |
- #' @export+ checkmate::assert_integerish(sigfig) |
|
| 273 | -+ | 3x |
- h_data_plot <- function(fit_km,+ format <- gsub("xx\\.|xx\\.x+", "xx", format)
|
|
| 274 | -+ | 3x |
- armval = "All",+ checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
|
|
| 275 | -+ | 3x |
- max_time = NULL) {
+ function(x, ...) {
|
|
| 276 | -18x | +! |
- y <- broom::tidy(fit_km)+ if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
|
|
| 277 | -+ | 12x |
-
+ num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#") |
|
| 278 | -18x | +12x |
- if (!is.null(fit_km$strata)) {
+ num <- gsub("\\.$", "", num) # remove trailing "."
|
|
| 279 | -18x | +
- fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
+
|
||
| 280 | -18x | +12x |
- strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2)+ format_value(num, format) |
|
| 281 | -18x | +
- strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
+ } |
||
| 282 | -18x | +
- y$strata <- factor(+ } |
||
| 283 | -18x | +
- vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2),+ |
||
| 284 | -18x | +
- levels = strata_levels+ #' Format fraction with lower threshold |
||
| 285 |
- )+ #' |
|||
| 286 |
- } else {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 287 | -! | +
- y$strata <- armval+ #' |
||
| 288 |
- }+ #' Formats a fraction when the second element of the input `x` is the fraction. It applies |
|||
| 289 |
-
+ #' a lower threshold, below which it is just stated that the fraction is smaller than that. |
|||
| 290 | -18x | +
- y_by_strata <- split(y, y$strata)+ #' |
||
| 291 | -18x | +
- y_by_strata_extended <- lapply(+ #' @param threshold (`proportion`)\cr lower threshold. |
||
| 292 | -18x | +
- y_by_strata,+ #' |
||
| 293 | -18x | +
- FUN = function(tbl) {
+ #' @return An `rtables` formatting function that takes numeric input `x` where the second |
||
| 294 | -53x | +
- first_row <- tbl[1L, ]+ #' element is the fraction that is formatted. If the fraction is above or equal to the threshold, |
||
| 295 | -53x | +
- first_row$time <- 0+ #' then it is displayed in percentage. If it is positive but below the threshold, it returns, |
||
| 296 | -53x | +
- first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
+ #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned. |
||
| 297 | -53x | +
- first_row$n.event <- first_row$n.censor <- 0+ #' |
||
| 298 | -53x | +
- first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1+ #' @examples |
||
| 299 | -53x | +
- first_row$std.error <- 0+ #' format_fun <- format_fraction_threshold(0.05) |
||
| 300 | -53x | +
- rbind(+ #' format_fun(x = c(20, 0.1)) |
||
| 301 | -53x | +
- first_row,+ #' format_fun(x = c(2, 0.01)) |
||
| 302 | -53x | +
- tbl+ #' format_fun(x = c(0, 0)) |
||
| 303 |
- )+ #' |
|||
| 304 |
- }+ #' @family formatting functions |
|||
| 305 |
- )+ #' @export |
|||
| 306 | -18x | +
- y <- do.call(rbind, y_by_strata_extended)+ format_fraction_threshold <- function(threshold) {
|
||
| 307 | -+ | 1x |
-
+ assert_proportion_value(threshold) |
|
| 308 | -18x | +1x |
- y$censor <- ifelse(y$n.censor > 0, y$estimate, NA)+ string_below_threshold <- paste0("<", round(threshold * 100))
|
|
| 309 | -18x | +1x |
- if (!is.null(max_time)) {
+ function(x, ...) {
|
|
| 310 | -1x | +3x |
- y <- y[y$time <= max(max_time), ]+ assert_proportion_value(x[2], include_boundaries = TRUE) |
|
| 311 | -+ | 3x |
- }+ ifelse( |
|
| 312 | -18x | +3x |
- y+ x[2] > 0.01, |
|
| 313 | -+ | 3x |
- }+ round(x[2] * 100), |
|
| 314 | -+ | 3x |
-
+ ifelse( |
|
| 315 | -+ | 3x |
- ## Deprecated Functions ----+ x[2] == 0, |
|
| 316 | -+ | 3x |
-
+ "0", |
|
| 317 | -+ | 3x |
- #' Helper function to create a KM plot+ string_below_threshold |
|
| 318 |
- #'+ ) |
|||
| 319 |
- #' @description `r lifecycle::badge("deprecated")`
+ ) |
|||
| 320 |
- #'+ } |
|||
| 321 |
- #' Draw the Kaplan-Meier plot using `ggplot2`.+ } |
|||
| 322 |
- #'+ |
|||
| 323 |
- #' @inheritParams g_km+ #' Format extreme values |
|||
| 324 |
- #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`.+ #' |
|||
| 325 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|||
| 326 |
- #' @return A `ggplot` object.+ #' |
|||
| 327 |
- #'+ #' `rtables` formatting functions that handle extreme values. |
|||
| 328 |
- #' @examples+ #' |
|||
| 329 |
- #' \donttest{
+ #' @param digits (`integer(1)`)\cr number of decimal places to display. |
|||
| 330 |
- #' library(dplyr)+ #' |
|||
| 331 |
- #' library(survival)+ #' @details For each input, apply a format to the specified number of `digits`. If the value is |
|||
| 332 |
- #'+ #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is |
|||
| 333 |
- #' fit_km <- tern_ex_adtte %>%+ #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2. |
|||
| 334 |
- #' filter(PARAMCD == "OS") %>%+ #' If it is zero, then returns "0.00". |
|||
| 335 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' |
|||
| 336 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' @family formatting functions |
|||
| 337 |
- #' xticks <- h_xticks(data = data_plot)+ #' @name extreme_format |
|||
| 338 |
- #' gg <- h_ggkm(+ NULL |
|||
| 339 |
- #' data = data_plot,+ |
|||
| 340 |
- #' censor_show = TRUE,+ #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings |
|||
| 341 |
- #' xticks = xticks,+ #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`. |
|||
| 342 |
- #' xlab = "Days",+ #' |
|||
| 343 |
- #' yval = "Survival",+ #' @return |
|||
| 344 |
- #' ylab = "Survival Probability",+ #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds, |
|||
| 345 |
- #' title = "Survival"+ #' and `format_string`, with thresholds formatted as strings. |
|||
| 346 |
- #' )+ #' |
|||
| 347 |
- #' gg+ #' @examples |
|||
| 348 |
- #' }+ #' h_get_format_threshold(2L) |
|||
| 351 |
- h_ggkm <- function(data,+ h_get_format_threshold <- function(digits = 2L) {
|
|||
| 352 | -+ | 2113x |
- xticks = NULL,+ checkmate::assert_integerish(digits) |
|
| 353 |
- yval = "Survival",+ |
|||
| 354 | -+ | 2113x |
- censor_show,+ low_threshold <- 1 / (10 ^ digits) # styler: off |
|
| 355 | -+ | 2113x |
- xlab,+ high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off |
|
| 356 |
- ylab,+ |
|||
| 357 | -+ | 2113x |
- ylim = NULL,+ string_below_threshold <- paste0("<", low_threshold)
|
|
| 358 | -+ | 2113x |
- title,+ string_above_threshold <- paste0(">", high_threshold)
|
|
| 359 |
- footnotes = NULL,+ |
|||
| 360 | -+ | 2113x |
- max_time = NULL,+ list( |
|
| 361 | -+ | 2113x |
- lwd = 1,+ "threshold" = c(low = low_threshold, high = high_threshold), |
|
| 362 | -+ | 2113x |
- lty = NULL,+ "format_string" = c(low = string_below_threshold, high = string_above_threshold) |
|
| 363 |
- pch = 3,+ ) |
|||
| 364 |
- size = 2,+ } |
|||
| 365 |
- col = NULL,+ |
|||
| 366 |
- ci_ribbon = FALSE,+ #' @describeIn extreme_format Internal helper function to apply a threshold format to a value. |
|||
| 367 |
- ggtheme = nestcolor::theme_nest()) {
+ #' Creates a formatted string to be used in Formatting Functions. |
|||
| 368 | -1x | +
- lifecycle::deprecate_warn(+ #' |
||
| 369 | -1x | +
- "0.9.4",+ #' @param x (`numeric(1)`)\cr value to format. |
||
| 370 | -1x | +
- "h_ggkm()",+ #' |
||
| 371 | -1x | +
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' @return |
||
| 372 |
- )+ #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation |
|||
| 373 | -1x | +
- checkmate::assert_numeric(lty, null.ok = TRUE)+ #' of the given value to the digit threshold, as a formatted string. |
||
| 374 | -1x | +
- checkmate::assert_character(col, null.ok = TRUE)+ #' |
||
| 375 |
-
+ #' @examples |
|||
| 376 | -1x | +
- if (is.null(ylim)) {
+ #' h_format_threshold(0.001) |
||
| 377 | -1x | +
- data_lims <- data+ #' h_format_threshold(1000) |
||
| 378 | -! | +
- if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]]+ #' |
||
| 379 | -1x | +
- if (!is.null(max_time)) {
+ #' @export |
||
| 380 | -! | +
- y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]])+ h_format_threshold <- function(x, digits = 2L) {
|
||
| 381 | -! | +2115x |
- y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]])+ if (is.na(x)) {
|
|
| 382 | -+ | 4x |
- } else {
+ return(x) |
|
| 383 | -1x | -
- y_lwr <- min(data_lims[["estimate"]])- |
- ||
| 384 | -1x | +
- y_upr <- max(data_lims[["estimate"]])+ } |
||
| 385 | +384 |
- }+ |
||
| 386 | -1x | +385 | +2111x |
- ylim <- c(y_lwr, y_upr)+ checkmate::assert_numeric(x, lower = 0) |
| 387 | +386 |
- }+ |
||
| 388 | -1x | +387 | +2111x |
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE)+ l_fmt <- h_get_format_threshold(digits) |
| 389 | +388 | |||
| 389 | +2111x | +
+ result <- if (x < l_fmt$threshold["low"] && 0 < x) {
+ |
+ ||
| 390 | -+ | 44x |
- # change estimates of survival to estimates of failure (1 - survival)+ l_fmt$format_string["low"] |
|
| 391 | -1x | +2111x |
- if (yval == "Failure") {
+ } else if (x > l_fmt$threshold["high"]) {
|
|
| 392 | -! | +99x |
- data$estimate <- 1 - data$estimate+ l_fmt$format_string["high"] |
|
| 393 | -! | +
- data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
+ } else {
|
||
| 394 | -! | +1968x |
- data$censor <- 1 - data$censor+ sprintf(fmt = paste0("%.", digits, "f"), x)
|
|
| 397 | -1x | +2111x |
- gg <- {
+ unname(result) |
|
| 398 | -1x | +
- ggplot2::ggplot(+ } |
||
| 399 | -1x | +
- data = data,+ |
||
| 400 | -1x | +
- mapping = ggplot2::aes(+ #' Format a single extreme value |
||
| 401 | -1x | +
- x = .data[["time"]],+ #' |
||
| 402 | -1x | +
- y = .data[["estimate"]],+ #' @description `r lifecycle::badge("stable")`
|
||
| 403 | -1x | +
- ymin = .data[["conf.low"]],+ #' |
||
| 404 | -1x | +
- ymax = .data[["conf.high"]],+ #' Create a formatting function for a single extreme value. |
||
| 405 | -1x | +
- color = .data[["strata"]],+ #' |
||
| 406 | -1x | +
- fill = .data[["strata"]]+ #' @inheritParams extreme_format |
||
| 407 |
- )+ #' |
|||
| 408 |
- ) ++ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value. |
|||
| 409 | -1x | +
- ggplot2::geom_hline(yintercept = 0)+ #' |
||
| 410 |
- }+ #' @examples |
|||
| 411 |
-
+ #' format_fun <- format_extreme_values(2L) |
|||
| 412 | -1x | +
- if (ci_ribbon) {
+ #' format_fun(x = 0.127) |
||
| 413 | -! | +
- gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0)+ #' format_fun(x = Inf) |
||
| 414 |
- }+ #' format_fun(x = 0) |
|||
| 415 |
-
+ #' format_fun(x = 0.009) |
|||
| 416 | -1x | +
- gg <- if (is.null(lty)) {
+ #' |
||
| 417 | -1x | +
- gg ++ #' @family formatting functions |
||
| 418 | -1x | +
- ggplot2::geom_step(linewidth = lwd)+ #' @export |
||
| 419 | -1x | +
- } else if (checkmate::test_number(lty)) {
+ format_extreme_values <- function(digits = 2L) {
|
||
| 420 | -! | +63x |
- gg ++ function(x, ...) {
|
|
| 421 | -! | +657x |
- ggplot2::geom_step(linewidth = lwd, lty = lty)+ checkmate::assert_scalar(x, na.ok = TRUE) |
|
| 422 | -1x | +
- } else if (is.numeric(lty)) {
+
|
||
| 423 | -! | +657x |
- gg ++ h_format_threshold(x = x, digits = digits) |
|
| 424 | -! | +
- ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ } |
||
| 425 | -! | +
- ggplot2::scale_linetype_manual(values = lty)+ } |
||
| 426 |
- }+ |
|||
| 427 |
-
+ #' Format extreme values part of a confidence interval |
|||
| 428 | -1x | +
- gg <- gg ++ #' |
||
| 429 | -1x | +
- ggplot2::coord_cartesian(ylim = ylim) ++ #' @description `r lifecycle::badge("stable")`
|
||
| 430 | -1x | +
- ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes)+ #' |
||
| 431 |
-
+ #' Formatting Function for extreme values part of a confidence interval. Values |
|||
| 432 | -1x | +
- if (!is.null(col)) {
+ #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2. |
||
| 433 | -! | +
- gg <- gg ++ #' |
||
| 434 | -! | +
- ggplot2::scale_color_manual(values = col) ++ #' @inheritParams extreme_format |
||
| 435 | -! | +
- ggplot2::scale_fill_manual(values = col)+ #' |
||
| 436 |
- }+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme |
|||
| 437 | -1x | +
- if (censor_show) {
+ #' values confidence interval. |
||
| 438 | -1x | +
- dt <- data[data$n.censor != 0, ]+ #' |
||
| 439 | -1x | +
- dt$censor_lbl <- factor("Censored")
+ #' @examples |
||
| 440 |
-
+ #' format_fun <- format_extreme_values_ci(2L) |
|||
| 441 | -1x | +
- gg <- gg + ggplot2::geom_point(+ #' format_fun(x = c(0.127, Inf)) |
||
| 442 | -1x | +
- data = dt,+ #' format_fun(x = c(0, 0.009)) |
||
| 443 | -1x | +
- ggplot2::aes(+ #' |
||
| 444 | -1x | +
- x = .data[["time"]],+ #' @family formatting functions |
||
| 445 | -1x | +
- y = .data[["censor"]],+ #' @export |
||
| 446 | -1x | +
- shape = .data[["censor_lbl"]]+ format_extreme_values_ci <- function(digits = 2L) {
|
||
| 447 | -+ | 71x |
- ),+ function(x, ...) {
|
|
| 448 | -1x | +726x |
- size = size,+ checkmate::assert_vector(x, len = 2) |
|
| 449 | -1x | +726x |
- show.legend = TRUE,+ l_result <- h_format_threshold(x = x[1], digits = digits) |
|
| 450 | -1x | +726x |
- inherit.aes = TRUE+ h_result <- h_format_threshold(x = x[2], digits = digits) |
|
| 451 |
- ) ++ |
|||
| 452 | -1x | +726x |
- ggplot2::scale_shape_manual(name = NULL, values = pch) ++ paste0("(", l_result, ", ", h_result, ")")
|
|
| 453 | -1x | +
- ggplot2::guides(+ } |
||
| 454 | -1x | +
- shape = ggplot2::guide_legend(override.aes = list(linetype = NA)),+ } |
||
| 455 | -1x | +
- fill = ggplot2::guide_legend(override.aes = list(shape = NA))+ |
||
| 456 |
- )+ #' Format automatically using data significant digits |
|||
| 457 |
- }+ #' |
|||
| 458 |
-
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 459 | -1x | +
- if (!is.null(max_time) && !is.null(xticks)) {
+ #' |
||
| 460 | -! | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))))+ #' Formatting function for the majority of default methods used in [analyze_vars()]. |
||
| 461 | -1x | +
- } else if (!is.null(xticks)) {
+ #' For non-derived values, the significant digits of data is used (e.g. range), while derived |
||
| 462 | -1x | +
- if (max(data$time) <= max(xticks)) {
+ #' values have one more digits (measure of location and dispersion like mean, standard deviation). |
||
| 463 | -1x | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)))+ #' This function can be called internally with "auto" like, for example, |
||
| 464 |
- } else {
+ #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
|
|||
| 465 | -! | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks)+ #' |
||
| 466 |
- }+ #' @param dt_var (`numeric`)\cr variable data the statistics were calculated from. Used only to |
|||
| 467 | -! | +
- } else if (!is.null(max_time)) {
+ #' find significant digits. In [analyze_vars] this comes from `.df_row` (see |
||
| 468 | -! | +
- gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time))+ #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No |
||
| 469 |
- }+ #' column split is considered. |
|||
| 470 |
-
+ #' @param x_stat (`string`)\cr string indicating the current statistical method used. |
|||
| 471 | -1x | +
- if (!is.null(ggtheme)) {
+ #' |
||
| 472 | -1x | +
- gg <- gg + ggtheme+ #' @return A string that `rtables` prints in a table cell. |
||
| 473 |
- }+ #' |
|||
| 474 |
-
+ #' @details |
|||
| 475 | -1x | +
- gg + ggplot2::theme(+ #' The internal function is needed to work with `rtables` default structure for |
||
| 476 | -1x | +
- legend.position = "bottom",+ #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation. |
||
| 477 | -1x | +
- legend.title = ggplot2::element_blank(),+ #' It can be more than one element (e.g. for `.stats = "mean_sd"`). |
||
| 478 | -1x | +
- legend.key.height = unit(0.02, "npc"),+ #' |
||
| 479 | -1x | +
- panel.grid.major.x = ggplot2::element_line(linewidth = 2)+ #' @examples |
||
| 480 |
- )+ #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4) |
|||
| 481 |
- }+ #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3])) |
|||
| 482 |
-
+ #' |
|||
| 483 |
- #' `ggplot` decomposition+ #' # x is the result coming into the formatting function -> res!! |
|||
| 484 |
- #'+ #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res) |
|||
| 485 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' format_auto(x_todo, "range")(x = range(x_todo)) |
|||
| 486 |
- #'+ #' no_sc_x <- c(0.0000001, 1) |
|||
| 487 |
- #' The elements composing the `ggplot` are extracted and organized in a `list`.+ #' format_auto(no_sc_x, "range")(x = no_sc_x) |
|||
| 489 |
- #' @param gg (`ggplot`)\cr a graphic to decompose.+ #' @family formatting functions |
|||
| 490 |
- #'+ #' @export |
|||
| 491 |
- #' @return A named `list` with elements:+ format_auto <- function(dt_var, x_stat) {
|
|||
| 492 | -+ | 10x |
- #' * `panel`: The panel.+ function(x = "", ...) {
|
|
| 493 | -+ | 18x |
- #' * `yaxis`: The y-axis.+ checkmate::assert_numeric(x, min.len = 1) |
|
| 494 | -+ | 18x |
- #' * `xaxis`: The x-axis.+ checkmate::assert_numeric(dt_var, min.len = 1) |
|
| 495 |
- #' * `xlab`: The x-axis label.+ # Defaults - they may be a param in the future |
|||
| 496 | -+ | 18x |
- #' * `ylab`: The y-axis label.+ der_stats <- c( |
|
| 497 | -+ | 18x |
- #' * `guide`: The legend.+ "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr", |
|
| 498 | -+ | 18x |
- #'+ "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi", |
|
| 499 | -+ | 18x |
- #' @examples+ "median_ci" |
|
| 500 |
- #' \donttest{
+ ) |
|||
| 501 | -+ | 18x |
- #' library(dplyr)+ nonder_stats <- c("n", "range", "min", "max")
|
|
| 502 |
- #' library(survival)+ |
|||
| 503 |
- #' library(grid)+ # Safenet for miss-modifications |
|||
| 504 | -+ | 18x |
- #'+ stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint |
|
| 505 | -+ | 18x |
- #' fit_km <- tern_ex_adtte %>%+ checkmate::assert_choice(x_stat, c(der_stats, nonder_stats)) |
|
| 506 |
- #' filter(PARAMCD == "OS") %>%+ |
|||
| 507 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ # Finds the max number of digits in data |
|||
| 508 | -+ | 18x |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>% |
|
| 509 | -+ | 18x |
- #' xticks <- h_xticks(data = data_plot)+ max() |
|
| 510 |
- #' gg <- h_ggkm(+ |
|||
| 511 | -+ | 18x |
- #' data = data_plot,+ if (x_stat %in% der_stats) {
|
|
| 512 | -+ | 8x |
- #' yval = "Survival",+ detect_dig <- detect_dig + 1 |
|
| 513 |
- #' censor_show = TRUE,+ } |
|||
| 514 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
|||
| 515 |
- #' title = "tt",+ # Render input |
|||
| 516 | -+ | 18x |
- #' footnotes = "ff"+ str_vals <- formatC(x, digits = detect_dig, format = "f") |
|
| 517 | -+ | 18x |
- #' )+ def_fmt <- get_formats_from_stats(x_stat)[[x_stat]] |
|
| 518 | -+ | 18x |
- #'+ str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]] |
|
| 519 | -+ | 18x |
- #' g_el <- h_decompose_gg(gg)+ if (length(str_fmt) != length(str_vals)) {
|
|
| 520 | -+ | 2x |
- #' grid::grid.newpage()+ stop( |
|
| 521 | -+ | 2x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5))+ "Number of inserted values as result (", length(str_vals),
|
|
| 522 | -+ | 2x |
- #' grid::grid.draw(g_el$panel)+ ") is not the same as there should be in the default tern formats for ", |
|
| 523 | -+ | 2x |
- #'+ x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ", |
|
| 524 | -+ | 2x |
- #' grid::grid.newpage()+ "See tern_default_formats to check all of them." |
|
| 525 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5))+ ) |
|||
| 526 |
- #' grid::grid.draw(with(g_el, cbind(ylab, yaxis)))+ } |
|||
| 527 |
- #' }+ |
|||
| 528 |
- #'+ # Squashing them together |
|||
| 529 | -+ | 16x |
- #' @export+ inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]] |
|
| 530 | -+ | 16x |
- h_decompose_gg <- function(gg) {
+ stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint |
|
| 531 | -1x | +
- lifecycle::deprecate_warn(+ |
||
| 532 | -1x | +16x |
- "0.9.4",+ out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
|
|
| 533 | -1x | +16x |
- "h_decompose_gg()",+ is_even <- seq_along(out) %% 2 == 0 |
|
| 534 | -1x | +16x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ out[is_even] <- str_vals |
|
| 535 | -+ | 16x |
- )+ out[!is_even] <- inv_str_fmt |
|
| 536 | -1x | +
- g_el <- ggplot2::ggplotGrob(gg)+ |
||
| 537 | -1x | +16x |
- y <- c(+ return(paste0(out, collapse = "")) |
|
| 538 | -1x | +
- panel = "panel",+ } |
||
| 539 | -1x | +
- yaxis = "axis-l",+ } |
||
| 540 | -1x | +
- xaxis = "axis-b",+ |
||
| 541 | -1x | +
- xlab = "xlab-b",+ # Utility function that could be useful in general |
||
| 542 | -1x | +
- ylab = "ylab-l",+ str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
|
||
| 543 | -1x | +34x |
- guide = "guide"+ regmatches(string, gregexpr(pattern, string), invert = invert) |
|
| 544 |
- )+ } |
|||
| 545 | -1x | +
- lapply(X = y, function(x) gtable::gtable_filter(g_el, x))+ |
||
| 546 |
- }+ # Helper function |
|||
| 547 |
-
+ count_decimalplaces <- function(dec) {
|
|||
| 548 | -+ | 161x |
- #' Helper function to prepare a KM layout+ if (is.na(dec)) {
|
|
| 549 | -+ | 6x |
- #'+ return(0) |
|
| 550 | -+ | 155x |
- #' @description `r lifecycle::badge("deprecated")`
+ } else if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
|
|
| 551 | -+ | 122x |
- #'+ nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]]) |
|
| 552 |
- #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve.+ } else {
|
|||
| 553 | -+ | 33x |
- #'+ return(0) |
|
| 554 |
- #' @inheritParams g_km+ } |
|||
| 555 |
- #' @inheritParams h_ggkm+ } |
|||
| 556 |
- #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`.+ |
|||
| 557 |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of+ #' Apply automatic formatting |
|||
| 558 |
- #' patient at risk matching the main grid of the Kaplan-Meier curve.+ #' |
|||
| 559 |
- #'+ #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with |
|||
| 560 |
- #' @return A grid layout.+ #' the correct implementation of `format_auto` for the given statistics, data, and variable. |
|||
| 562 |
- #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the+ #' @inheritParams argument_convention |
|||
| 563 |
- #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space.+ #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds |
|||
| 564 |
- #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient+ #' to an element in `.formats`, with matching names. |
|||
| 565 |
- #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of+ #' |
|||
| 566 |
- #' the strata name.+ #' @keywords internal |
|||
| 567 |
- #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table.+ apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
|
|||
| 568 | -+ | 526x |
- #'+ is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1)) |
|
| 569 | -+ | 526x |
- #' @examples+ if (any(is_auto_fmt)) {
|
|
| 570 | -+ | 3x |
- #' \donttest{
+ auto_stats <- x_stats[is_auto_fmt] |
|
| 571 | +3x | +
+ var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ |
+ ||
| 572 | +3x | +
+ .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df)+ |
+ ||
| 573 |
- #' library(dplyr)+ }+ |
+ |||
| 574 | +526x | +
+ .formats |
||
| 572 | +575 |
- #' library(survival)+ } |
| 573 | +1 |
- #' library(grid)+ #' Convert `rtable` objects to `ggplot` objects |
||
| 574 | +2 |
#' |
||
| 575 | +3 |
- #' fit_km <- tern_ex_adtte %>%+ #' @description `r lifecycle::badge("experimental")`
|
||
| 576 | +4 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 577 | +5 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using |
||
| 578 | +6 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored. |
||
| 579 | +7 |
- #' xticks <- h_xticks(data = data_plot)+ #' |
||
| 580 | +8 |
- #' gg <- h_ggkm(+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
||
| 581 | +9 |
- #' data = data_plot,+ #' @param fontsize (`numeric(1)`)\cr font size. |
||
| 582 | +10 |
- #' censor_show = TRUE,+ #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
||
| 583 | +11 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths |
||
| 584 | +12 |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ #' are calculated according to maximum number of characters per column. |
||
| 585 | +13 |
- #' )+ #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between |
||
| 586 | +14 |
- #' g_el <- h_decompose_gg(gg)+ #' the first (label) column and the second column of `tbl`. If `colwidths` is specified, |
||
| 587 | +15 |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ #' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0. |
||
| 588 | +16 |
- #' grid.show.layout(lyt)+ #' |
||
| 589 | +17 |
- #' }+ #' @return A `ggplot` object. |
||
| 590 | +18 |
#' |
||
| 591 | +19 |
- #' @export+ #' @examples |
||
| 592 | +20 |
- h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
+ #' dta <- data.frame( |
||
| 593 | -1x | +|||
| 21 | +
- lifecycle::deprecate_warn(+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|||
| 594 | -1x | +|||
| 22 | +
- "0.9.4",+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
|||
| 595 | -1x | +|||
| 23 | +
- "h_km_layout()",+ #' AVAL = c(9:1, rep(NA, 9)) |
|||
| 596 | -1x | +|||
| 24 | +
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' ) |
|||
| 597 | +25 |
- )+ #' |
||
| 598 | -1x | +|||
| 26 | +
- txtlines <- levels(as.factor(data$strata))+ #' lyt <- basic_table() %>% |
|||
| 599 | -1x | +|||
| 27 | +
- nlines <- nlevels(as.factor(data$strata))+ #' split_cols_by(var = "ARM") %>% |
|||
| 600 | -1x | +|||
| 28 | +
- col_annot_width <- max(+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 601 | -1x | +|||
| 29 | +
- c(+ #' analyze_vars(vars = "AVAL") |
|||
| 602 | -1x | +|||
| 30 | +
- as.numeric(grid::convertX(g_el$yaxis$widths + g_el$ylab$widths, "pt")),+ #' |
|||
| 603 | -1x | +|||
| 31 | +
- as.numeric(+ #' tbl <- build_table(lyt, df = dta) |
|||
| 604 | -1x | +|||
| 32 | +
- grid::convertX(+ #' |
|||
| 605 | -1x | +|||
| 33 | +
- grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt"+ #' rtable2gg(tbl) |
|||
| 606 | +34 |
- )+ #' |
||
| 607 | +35 |
- )+ #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) |
||
| 608 | +36 |
- )+ #' |
||
| 609 | +37 |
- )+ #' @export |
||
| 610 | +38 |
-
+ rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
|
||
| 611 | -1x | +39 | +6x |
- ttl_row <- as.numeric(!is.null(title))+ mat <- rtables::matrix_form(tbl, indent_rownames = TRUE) |
| 612 | -1x | +40 | +6x |
- foot_row <- as.numeric(!is.null(footnotes))+ mat_strings <- formatters::mf_strings(mat) |
| 613 | -1x | +41 | +6x |
- no_tbl_ind <- c()+ mat_aligns <- formatters::mf_aligns(mat) |
| 614 | -1x | +42 | +6x |
- ht_x <- c()+ mat_indent <- formatters::mf_rinfo(mat)$indent |
| 615 | -1x | +43 | +6x |
- ht_units <- c()+ mat_display <- formatters::mf_display(mat)+ |
+
| 44 | +6x | +
+ nlines_hdr <- formatters::mf_nlheader(mat)+ |
+ ||
| 45 | +6x | +
+ shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x)))) |
||
| 616 | +46 | |||
| 617 | -1x | +47 | +6x |
- if (ttl_row == 1) {
+ tbl_df <- data.frame(mat_strings) |
| 618 | -1x | +48 | +6x |
- no_tbl_ind <- c(no_tbl_ind, TRUE)+ body_rows <- seq(nlines_hdr + 1, nrow(tbl_df)) |
| 619 | -1x | +49 | +6x |
- ht_x <- c(ht_x, 2)+ 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 |
||
| 620 | -1x | +52 | +6x |
- ht_units <- c(ht_units, "lines")+ tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
+ |
+
| 53 | +42x | +
+ ind_i <- mat_indent[i - nlines_hdr] * 4+ |
+ ||
| 54 | +18x | +
+ if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1]
|
||
| 621 | +55 |
- }+ }) |
||
| 622 | +56 | |||
| 623 | -1x | +|||
| 57 | +
- no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2))+ # Get column widths |
|||
| 624 | -1x | +58 | +6x |
- ht_x <- c(+ if (is.null(colwidths)) {
|
| 625 | -1x | +59 | +6x |
- ht_x,+ colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1 |
| 626 | -1x | +|||
| 60 | +
- 1,+ } |
|||
| 627 | -1x | +61 | +6x |
- grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") + grid::unit(5, "pt"),+ tot_width <- sum(colwidths) + lbl_col_padding |
| 628 | -1x | +|||
| 62 | +
- grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"),+ |
|||
| 629 | -1x | +63 | +6x |
- 1,+ if (length(shared_hdr_rows) > 0) {
|
| 630 | -1x | +64 | +5x |
- nlines + 0.5,+ tbl_df <- tbl_df[-shared_hdr_rows, ] |
| 631 | -1x | +65 | +5x |
- grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt")+ mat_aligns <- mat_aligns[-shared_hdr_rows, ] |
| 632 | +66 |
- )+ }+ |
+ ||
| 67 | ++ | + | ||
| 633 | -1x | +68 | +6x |
- ht_units <- c(+ res <- ggplot(data = tbl_df) + |
| 634 | -1x | +69 | +6x |
- ht_units,+ theme_void() + |
| 635 | -1x | +70 | +6x |
- "null",+ scale_x_continuous(limits = c(0, tot_width)) + |
| 636 | -1x | +71 | +6x |
- "pt",+ scale_y_continuous(limits = c(0, nrow(mat_strings))) + |
| 637 | -1x | +72 | +6x |
- "pt",+ annotate( |
| 638 | -1x | +73 | +6x |
- "lines",+ "segment", |
| 639 | -1x | +74 | +6x |
- "lines",+ x = 0, xend = tot_width, |
| 640 | -1x | +75 | +6x |
- "pt"+ y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5 |
| 641 | +76 |
- )+ ) |
||
| 642 | +77 | |||
| 78 | ++ |
+ # If header content spans multiple columns, center over these columns+ |
+ ||
| 643 | -1x | +79 | +6x |
- if (foot_row == 1) {
+ if (length(shared_hdr_rows) > 0) {
|
| 644 | -1x | +80 | +5x |
- no_tbl_ind <- c(no_tbl_ind, TRUE)+ mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ]) |
| 645 | -1x | +81 | +5x |
- ht_x <- c(ht_x, 1)+ for (hr in shared_hdr_rows) {
|
| 646 | -1x | +82 | +6x |
- ht_units <- c(ht_units, "lines")+ hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]] |
| 647 | -+ | |||
| 83 | +6x |
- }+ hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr) |
||
| 648 | -1x | +84 | +6x |
- if (annot_at_risk) {
+ for (idx_hl in seq_len(ncol(hdr_lbls))) {
|
| 649 | -1x | +85 | +13x |
- no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row)+ cur_lbl <- tail(hdr_lbls[, idx_hl], 1) |
| 650 | -1x | +86 | +13x |
- if (!annot_at_risk_title) {
+ which_cols <- if (hr == 1) {
|
| 651 | -! | +|||
| 87 | +9x |
- no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE+ which(mat_strings[hr, ] == hdr_lbls[idx_hl])+ |
+ ||
| 88 | +13x | +
+ } else { # for >2 col splits, only print labels for each unique combo of nested columns
+ |
+ ||
| 89 | +4x | +
+ which(+ |
+ ||
| 90 | +4x | +
+ apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl])) |
||
| 652 | +91 |
- }+ ) |
||
| 653 | +92 |
- } else {
+ } |
||
| 654 | -! | +|||
| 93 | +13x |
- no_at_risk_tbl <- no_tbl_ind+ line_pos <- c(+ |
+ ||
| 94 | +13x | +
+ sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding,+ |
+ ||
| 95 | +13x | +
+ sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding |
||
| 655 | +96 |
- }+ ) |
||
| 656 | +97 | |||
| 657 | -1x | +98 | +13x |
- grid::grid.layout(+ res <- res + |
| 658 | -1x | +99 | +13x |
- nrow = sum(no_at_risk_tbl), ncol = 2,+ annotate( |
| 659 | -1x | +100 | +13x |
- widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
+ "text", |
| 660 | -1x | +101 | +13x |
- heights = grid::unit(+ x = mean(line_pos), |
| 661 | -1x | +102 | +13x |
- x = ht_x[no_at_risk_tbl],+ y = nrow(mat_strings) + 1 - hr, |
| 662 | -1x | +103 | +13x |
- units = ht_units[no_at_risk_tbl]+ label = cur_lbl, |
| 663 | -+ | |||
| 104 | +13x |
- )+ size = fontsize / .pt |
||
| 664 | +105 |
- )+ ) + |
||
| 665 | -+ | |||
| 106 | +13x |
- }+ annotate( |
||
| 666 | -+ | |||
| 107 | +13x |
-
+ "segment", |
||
| 667 | -+ | |||
| 108 | +13x |
- #' Helper function to create patient-at-risk grobs+ x = line_pos[1], |
||
| 668 | -+ | |||
| 109 | +13x |
- #'+ xend = line_pos[2], |
||
| 669 | -+ | |||
| 110 | +13x |
- #' @description `r lifecycle::badge("deprecated")`
+ y = nrow(mat_strings) - hr + 0.5, |
||
| 670 | -+ | |||
| 111 | +13x |
- #'+ yend = nrow(mat_strings) - hr + 0.5 |
||
| 671 | +112 |
- #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of+ ) |
||
| 672 | +113 |
- #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is+ } |
||
| 673 | +114 |
- #' also obtained.+ } |
||
| 674 | +115 |
- #'+ } |
||
| 675 | +116 |
- #' @inheritParams g_km+ |
||
| 676 | +117 |
- #' @inheritParams h_ggkm+ # Add table columns |
||
| 677 | -+ | |||
| 118 | +6x |
- #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which+ for (i in seq_len(ncol(tbl_df))) {
|
||
| 678 | -+ | |||
| 119 | +40x |
- #' includes the number of patients at risk at given time points.+ res <- res + annotate( |
||
| 679 | -+ | |||
| 120 | +40x |
- #' @param xlim (`numeric(1)`)\cr the maximum value on the x-axis (used to ensure the at risk table aligns with the KM+ "text", |
||
| 680 | -+ | |||
| 121 | +40x |
- #' graph).+ x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding, |
||
| 681 | -+ | |||
| 122 | +40x |
- #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ y = rev(seq_len(nrow(tbl_df))), |
||
| 682 | -+ | |||
| 123 | +40x |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ label = tbl_df[, i], |
||
| 683 | -+ | |||
| 124 | +40x |
- #'+ hjust = mat_aligns[, i], |
||
| 684 | -+ | |||
| 125 | +40x |
- #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three+ size = fontsize / .pt |
||
| 685 | +126 |
- #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`.+ ) |
||
| 686 | +127 |
- #'+ } |
||
| 687 | +128 |
- #' @examples+ |
||
| 688 | -+ | |||
| 129 | +6x |
- #' \donttest{
+ res |
||
| 689 | +130 |
- #' library(dplyr)+ } |
||
| 690 | +131 |
- #' library(survival)+ |
||
| 691 | +132 |
- #' library(grid)+ #' Convert `data.frame` object to `ggplot` object |
||
| 692 | +133 |
#' |
||
| 693 | +134 |
- #' fit_km <- tern_ex_adtte %>%+ #' @description `r lifecycle::badge("experimental")`
|
||
| 694 | +135 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 695 | +136 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' Given a `data.frame` object, performs basic conversion to a [ggplot2::ggplot()] object built using |
||
| 696 | +137 |
- #'+ #' functions from the `ggplot2` package. |
||
| 697 | +138 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' |
||
| 698 | +139 |
- #'+ #' @param df (`data.frame`)\cr a data frame. |
||
| 699 | +140 |
- #' xticks <- h_xticks(data = data_plot)+ #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
||
| 700 | +141 |
- #'+ #' `colwidths` corresponds to the column of `df` in the same position. If `NULL`, column widths |
||
| 701 | +142 |
- #' gg <- h_ggkm(+ #' are calculated according to maximum number of characters per column. |
||
| 702 | +143 |
- #' data = data_plot,+ #' @param font_size (`numeric(1)`)\cr font size. |
||
| 703 | +144 |
- #' censor_show = TRUE,+ #' @param col_labels (`flag`)\cr whether the column names (labels) of `df` should be used as the first row |
||
| 704 | +145 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ #' of the output table. |
||
| 705 | +146 |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ #' @param col_lab_fontface (`string`)\cr font face to apply to the first row (of column labels |
||
| 706 | +147 |
- #' )+ #' if `col_labels = TRUE`). Defaults to `"bold"`. |
||
| 707 | +148 |
- #'+ #' @param hline (`flag`)\cr whether a horizontal line should be printed below the first row of the table. |
||
| 708 | +149 |
- #' # The annotation table reports the patient at risk for a given strata and+ #' @param bg_fill (`string`)\cr table background fill color. |
||
| 709 | +150 |
- #' # times (`xticks`).+ #' |
||
| 710 | +151 |
- #' annot_tbl <- summary(fit_km, times = xticks)+ #' @return A `ggplot` object. |
||
| 711 | +152 |
- #' if (is.null(fit_km$strata)) {
+ #' |
||
| 712 | +153 |
- #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All"))+ #' @examples |
||
| 713 | -- |
- #' } else {
- |
- ||
| 714 | -- |
- #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
- |
- ||
| 715 | -- |
- #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]- |
- ||
| 716 | -- |
- #' annot_tbl <- data.frame(- |
- ||
| 717 | +154 |
- #' n.risk = annot_tbl$n.risk,+ #' \dontrun{
|
||
| 718 | +155 |
- #' time = annot_tbl$time,+ #' df2gg(head(iris, 5)) |
||
| 719 | +156 |
- #' strata = annot_tbl$strata+ #' |
||
| 720 | +157 |
- #' )+ #' df2gg(head(iris, 5), font_size = 15, colwidths = c(1, 1, 1, 1, 1)) |
||
| 721 | +158 |
#' } |
||
| 722 | -- |
- #'- |
- ||
| 723 | +159 |
- #' # The annotation table is transformed into a grob.+ #' @keywords internal |
||
| 724 | +160 |
- #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks))+ df2gg <- function(df, |
||
| 725 | +161 |
- #'+ colwidths = NULL, |
||
| 726 | +162 |
- #' # For the representation, the layout is estimated for which the decomposition+ font_size = 10, |
||
| 727 | +163 |
- #' # of the graphic element is necessary.+ col_labels = TRUE, |
||
| 728 | +164 |
- #' g_el <- h_decompose_gg(gg)+ col_lab_fontface = "bold", |
||
| 729 | +165 |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ hline = TRUE, |
||
| 730 | +166 |
- #'+ bg_fill = NULL) {
|
||
| 731 | +167 |
- #' grid::grid.newpage()+ # convert to text |
||
| 732 | -+ | |||
| 168 | +19x |
- #' pushViewport(viewport(layout = lyt, height = .95, width = .95))+ df <- as.data.frame(apply(df, 1:2, function(x) if (is.na(x)) "NA" else as.character(x))) |
||
| 733 | +169 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1))+ |
||
| 734 | -+ | |||
| 170 | +19x |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2))+ if (col_labels) {
|
||
| 735 | -+ | |||
| 171 | +10x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1))+ df <- as.matrix(df) |
||
| 736 | -+ | |||
| 172 | +10x |
- #' grid::grid.draw(tbl$at_risk)+ df <- rbind(colnames(df), df) |
||
| 737 | +173 |
- #' popViewport()+ } |
||
| 738 | +174 |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1))+ |
||
| 739 | +175 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1))+ # Get column widths |
||
| 740 | -+ | |||
| 176 | +19x |
- #' grid::grid.draw(tbl$label)+ if (is.null(colwidths)) {
|
||
| 741 | -+ | |||
| 177 | +1x |
- #' }+ colwidths <- apply(df, 2, function(x) max(nchar(x), na.rm = TRUE)) |
||
| 742 | +178 |
- #'+ } |
||
| 743 | -+ | |||
| 179 | +19x |
- #' @export+ tot_width <- sum(colwidths) |
||
| 744 | +180 |
- h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
+
|
||
| 745 | -1x | +181 | +19x |
- lifecycle::deprecate_warn(+ res <- ggplot(data = df) + |
| 746 | -1x | +182 | +19x |
- "0.9.4",+ theme_void() + |
| 747 | -1x | +183 | +19x |
- "h_grob_tbl_at_risk()",+ scale_x_continuous(limits = c(0, tot_width)) + |
| 748 | -1x | +184 | +19x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ scale_y_continuous(limits = c(1, nrow(df))) |
| 749 | +185 |
- )- |
- ||
| 750 | -1x | -
- txtlines <- levels(as.factor(data$strata))- |
- ||
| 751 | -1x | -
- nlines <- nlevels(as.factor(data$strata))+ |
||
| 752 | -1x | +186 | +9x |
- y_int <- annot_tbl$time[2] - annot_tbl$time[1]+ if (!is.null(bg_fill)) res <- res + theme(plot.background = element_rect(fill = bg_fill)) |
| 753 | -1x | +|||
| 187 | +
- annot_tbl <- expand.grid(+ |
|||
| 754 | -1x | +188 | +19x |
- time = seq(0, xlim, y_int),+ if (hline) {
|
| 755 | -1x | +189 | +10x |
- strata = unique(annot_tbl$strata)+ res <- res + |
| 756 | -1x | +190 | +10x |
- ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
+ annotate( |
| 757 | -1x | +191 | +10x |
- annot_tbl[is.na(annot_tbl)] <- 0+ "segment", |
| 758 | -1x | +192 | +10x |
- y_str_unit <- as.numeric(annot_tbl$strata)+ x = 0 + 0.2 * colwidths[2], xend = tot_width - 0.1 * tail(colwidths, 1), |
| 759 | -1x | +193 | +10x |
- vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines"))+ y = nrow(df) - 0.5, yend = nrow(df) - 0.5 |
| 760 | -1x | +|||
| 194 | +
- if (title) {
+ ) |
|||
| 761 | -1x | +|||
| 195 | +
- gb_table_title <- grid::gList(+ } |
|||
| 762 | -1x | +|||
| 196 | +
- grid::textGrob(+ |
|||
| 763 | -1x | +197 | +19x |
- label = "Patients at Risk:",+ for (i in seq_len(ncol(df))) {
|
| 764 | -1x | +198 | +86x |
- x = 1,+ line_pos <- c( |
| 765 | -1x | +199 | +86x |
- y = grid::unit(0.2, "native"),+ if (i == 1) 0 else sum(colwidths[1:(i - 1)]), |
| 766 | -1x | -
- gp = grid::gpar(fontface = "bold", fontsize = 10)- |
- ||
| 767 | -+ | 200 | +86x |
- )+ sum(colwidths[1:i]) |
| 768 | +201 |
) |
||
| 769 | -- |
- }- |
- ||
| 770 | -1x | -
- gb_table_left_annot <- grid::gList(- |
- ||
| 771 | -1x | -
- grid::rectGrob(- |
- ||
| 772 | -1x | +202 | +86x |
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ res <- res + |
| 773 | -1x | +203 | +86x |
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ annotate( |
| 774 | -1x | -
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0- |
- ||
| 775 | -+ | 204 | +86x |
- ),+ "text", |
| 776 | -1x | +205 | +86x |
- grid::textGrob(+ x = mean(line_pos), |
| 777 | -1x | +206 | +86x |
- label = unique(annot_tbl$strata),+ y = rev(seq_len(nrow(df))), |
| 778 | -1x | +207 | +86x |
- x = 0.5,+ label = df[, i], |
| 779 | -1x | +208 | +86x |
- y = grid::unit(+ size = font_size / .pt, |
| 780 | -1x | +209 | +86x |
- (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75,+ fontface = if (col_labels) {
|
| 781 | -1x | +210 | +32x |
- "native"+ c(col_lab_fontface, rep("plain", nrow(df) - 1))
|
| 782 | +211 |
- ),+ } else {
|
||
| 783 | -1x | +212 | +54x |
- gp = grid::gpar(fontface = "italic", fontsize = 10)+ rep("plain", nrow(df))
|
| 784 | +213 |
- )+ } |
||
| 785 | +214 |
- )+ ) |
||
| 786 | -1x | +|||
| 215 | +
- gb_patient_at_risk <- grid::gList(+ } |
|||
| 787 | -1x | +|||
| 216 | +
- grid::rectGrob(+ |
|||
| 788 | -1x | +217 | +19x |
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ res |
| 789 | -1x | +|||
| 218 | +
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ } |
|||
| 790 | -1x | +
| 1 | +
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ #' Compare variables between groups |
|||
| 791 | +2 |
- ),+ #' |
||
| 792 | -1x | +|||
| 3 | +
- grid::textGrob(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 793 | -1x | +|||
| 4 | +
- label = annot_tbl$n.risk,+ #' |
|||
| 794 | -1x | +|||
| 5 | +
- x = grid::unit(annot_tbl$time, "native"),+ #' The analyze function [compare_vars()] creates a layout element to summarize and compare one or more variables, using |
|||
| 795 | -1x | +|||
| 6 | +
- y = grid::unit(+ #' the S3 generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics |
|||
| 796 | -1x | +|||
| 7 | +
- (max(y_str_unit) - y_str_unit) + .5,+ #' for numeric variables can be viewed by running `get_stats("analyze_vars_numeric", add_pval = TRUE)` and for
|
|||
| 797 | -1x | +|||
| 8 | +
- "line"+ #' non-numeric variables by running `get_stats("analyze_vars_counts", add_pval = TRUE)`. Use the `.stats` parameter to
|
|||
| 798 | -1x | +|||
| 9 | +
- ) # maybe native+ #' specify the statistics to include in your output summary table. |
|||
| 799 | +10 |
- )+ #' |
||
| 800 | +11 |
- )+ #' Prior to using this function in your table layout you must use [rtables::split_cols_by()] to create a column |
||
| 801 | +12 |
-
+ #' split on the variable to be used in comparisons, and specify a reference group via the `ref_group` parameter. |
||
| 802 | -1x | +|||
| 13 | +
- ret <- list(+ #' Comparisons can be performed for each group (column) against the specified reference group by including the p-value |
|||
| 803 | -1x | +|||
| 14 | +
- at_risk = grid::gList(+ #' statistic. |
|||
| 804 | -1x | +|||
| 15 | +
- grid::gTree(+ #' |
|||
| 805 | -1x | +|||
| 16 | +
- vp = vp_table,+ #' @inheritParams argument_convention |
|||
| 806 | -1x | +|||
| 17 | +
- children = grid::gList(+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 807 | -1x | +|||
| 18 | +
- grid::gTree(+ #' |
|||
| 808 | -1x | +|||
| 19 | +
- vp = grid::dataViewport(+ #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric", add_pval = TRUE))``
|
|||
| 809 | -1x | +|||
| 20 | +
- xscale = c(0, xlim) + c(-0.05, 0.05) * xlim,+ #' |
|||
| 810 | -1x | +|||
| 21 | +
- yscale = c(0, nlines + 1),+ #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts", add_pval = TRUE))``
|
|||
| 811 | -1x | +|||
| 22 | +
- extension = c(0.05, 0)+ #' |
|||
| 812 | +23 |
- ),+ #' @note |
||
| 813 | -1x | +|||
| 24 | +
- children = grid::gList(gb_patient_at_risk)+ #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions |
|||
| 814 | +25 |
- )+ #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would |
||
| 815 | +26 |
- )+ #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted |
||
| 816 | +27 |
- )+ #' for as explicit factor levels. |
||
| 817 | +28 |
- ),+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
||
| 818 | -1x | +|||
| 29 | +
- label = grid::gList(+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
|||
| 819 | -1x | +|||
| 30 | +
- grid::gTree(+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
|||
| 820 | -1x | +|||
| 31 | +
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
|||
| 821 | -1x | +|||
| 32 | +
- children = grid::gList(+ #' * For character variables, automatic conversion to factor does not guarantee that the table |
|||
| 822 | -1x | +|||
| 33 | +
- grid::gTree(+ #' will be generated correctly. In particular for sparse tables this very likely can fail. |
|||
| 823 | -1x | +|||
| 34 | +
- vp = grid::dataViewport(+ #' Therefore it is always better to manually convert character variables to factors during pre-processing. |
|||
| 824 | -1x | +|||
| 35 | +
- xscale = 0:1,+ #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison |
|||
| 825 | -1x | +|||
| 36 | +
- yscale = c(0, nlines + 1),+ #' is well defined. |
|||
| 826 | -1x | +|||
| 37 | +
- extension = c(0.0, 0)+ #' |
|||
| 827 | +38 |
- ),+ #' @seealso [s_summary()] which is used internally to compute a summary within `s_compare()`, and [a_summary()] |
||
| 828 | -1x | +|||
| 39 | +
- children = grid::gList(gb_table_left_annot)+ #' which is used (with `compare = TRUE`) as the analysis function for `compare_vars()`. |
|||
| 829 | +40 |
- )+ #' |
||
| 830 | +41 |
- )+ #' @name compare_variables |
||
| 831 | +42 |
- )+ #' @include analyze_variables.R |
||
| 832 | +43 |
- )+ #' @order 1 |
||
| 833 | +44 |
- )+ NULL |
||
| 834 | +45 | |||
| 835 | -1x | -
- if (title) {
- |
- ||
| 836 | -1x | +|||
| 46 | +
- ret[["title"]] <- grid::gList(+ #' @describeIn compare_variables S3 generic function to produce a comparison summary. |
|||
| 837 | -1x | +|||
| 47 | +
- grid::gTree(+ #' |
|||
| 838 | -1x | +|||
| 48 | +
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ #' @return |
|||
| 839 | -1x | +|||
| 49 | +
- children = grid::gList(+ #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values. |
|||
| 840 | -1x | +|||
| 50 | +
- grid::gTree(+ #' |
|||
| 841 | -1x | +|||
| 51 | +
- vp = grid::dataViewport(+ #' @export |
|||
| 842 | -1x | +|||
| 52 | +
- xscale = 0:1,+ s_compare <- function(x, |
|||
| 843 | -1x | +|||
| 53 | +
- yscale = c(0, 1),+ .ref_group, |
|||
| 844 | -1x | +|||
| 54 | +
- extension = c(0, 0)+ .in_ref_col, |
|||
| 845 | +55 |
- ),+ ...) {
|
||
| 846 | -1x | +56 | +35x |
- children = grid::gList(gb_table_title)+ UseMethod("s_compare", x)
|
| 847 | +57 |
- )+ } |
||
| 848 | +58 |
- )+ |
||
| 849 | +59 |
- )+ #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test |
||
| 850 | +60 |
- )+ #' to calculate the p-value. |
||
| 851 | +61 |
- }+ #' |
||
| 852 | +62 |
-
+ #' @method s_compare numeric |
||
| 853 | -1x | +|||
| 63 | +
- ret+ #' |
|||
| 854 | +64 |
- }+ #' @examples |
||
| 855 | +65 |
-
+ #' # `s_compare.numeric` |
||
| 856 | +66 |
- #' Helper function to create survival estimation grobs+ #' |
||
| 857 | +67 |
- #'+ #' ## Usual case where both this and the reference group vector have more than 1 value. |
||
| 858 | +68 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE) |
||
| 859 | +69 |
#' |
||
| 860 | +70 |
- #' The survival fit is transformed in a grob containing a table with groups in+ #' ## If one group has not more than 1 value, then p-value is not calculated. |
||
| 861 | +71 |
- #' rows characterized by N, median and 95% confidence interval.+ #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE) |
||
| 862 | +72 |
#' |
||
| 863 | +73 |
- #' @inheritParams g_km+ #' ## Empty numeric does not fail, it returns NA-filled items and no p-value. |
||
| 864 | +74 |
- #' @inheritParams h_data_plot+ #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE) |
||
| 865 | +75 |
- #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()].+ #' |
||
| 866 | +76 |
- #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location.+ #' @export |
||
| 867 | +77 |
- #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location.+ s_compare.numeric <- function(x, |
||
| 868 | +78 |
- #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob.+ .ref_group, |
||
| 869 | +79 |
- #'+ .in_ref_col, |
||
| 870 | +80 |
- #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ ...) {
|
||
| 871 | -+ | |||
| 81 | +13x |
- #'+ checkmate::assert_numeric(x) |
||
| 872 | -+ | |||
| 82 | +13x |
- #' @examples+ checkmate::assert_numeric(.ref_group) |
||
| 873 | -+ | |||
| 83 | +13x |
- #' \donttest{
+ checkmate::assert_flag(.in_ref_col) |
||
| 874 | +84 |
- #' library(dplyr)+ |
||
| 875 | -+ | |||
| 85 | +13x |
- #' library(survival)+ y <- s_summary.numeric(x = x, ...) |
||
| 876 | +86 |
- #' library(grid)+ |
||
| 877 | -+ | |||
| 87 | +13x |
- #'+ y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
|
||
| 878 | -+ | |||
| 88 | +9x |
- #' grid::grid.newpage()+ stats::t.test(x, .ref_group)$p.value |
||
| 879 | +89 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ } else {
|
||
| 880 | -+ | |||
| 90 | +4x |
- #' tern_ex_adtte %>%+ character() |
||
| 881 | +91 |
- #' filter(PARAMCD == "OS") %>%+ } |
||
| 882 | +92 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ |
||
| 883 | -+ | |||
| 93 | +13x |
- #' h_grob_median_surv() %>%+ y |
||
| 884 | +94 |
- #' grid::grid.draw()+ } |
||
| 885 | +95 |
- #' }+ |
||
| 886 | +96 |
- #'+ #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test |
||
| 887 | +97 |
- #' @export+ #' to calculate the p-value. |
||
| 888 | +98 |
- h_grob_median_surv <- function(fit_km,+ #' |
||
| 889 | +99 |
- armval = "All",+ #' @param denom (`string`)\cr choice of denominator for factor proportions, |
||
| 890 | +100 |
- x = 0.9,+ #' can only be `n` (number of values in this row and column intersection). |
||
| 891 | +101 |
- y = 0.9,+ #' |
||
| 892 | +102 |
- width = grid::unit(0.3, "npc"),+ #' @method s_compare factor |
||
| 893 | +103 |
- ttheme = gridExtra::ttheme_default()) {
- |
- ||
| 894 | -1x | -
- lifecycle::deprecate_warn(+ #' |
||
| 895 | -1x | +|||
| 104 | +
- "0.9.4",+ #' @examples |
|||
| 896 | -1x | +|||
| 105 | +
- "h_grob_median_surv()",+ #' # `s_compare.factor` |
|||
| 897 | -1x | +|||
| 106 | +
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' |
|||
| 898 | +107 |
- )+ #' ## Basic usage: |
||
| 899 | -1x | +|||
| 108 | +
- data <- h_tbl_median_surv(fit_km, armval = armval)+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
|||
| 900 | +109 |
-
+ #' y <- factor(c("a", "b", "c"))
|
||
| 901 | -1x | +|||
| 110 | +
- width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE) |
|||
| 902 | -1x | +|||
| 111 | +
- height <- width * (nrow(data) + 1) / 12+ #' |
|||
| 903 | +112 |
-
+ #' ## Management of NA values. |
||
| 904 | -1x | +|||
| 113 | +
- w <- paste(" ", c(
+ #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
|
|||
| 905 | -1x | +|||
| 114 | +
- rownames(data)[which.max(nchar(rownames(data)))],+ #' y <- explicit_na(factor(c("a", "b", "c", NA)))
|
|||
| 906 | -1x | +|||
| 115 | +
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
|||
| 907 | +116 |
- ))+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
||
| 908 | -1x | +|||
| 117 | +
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ #' |
|||
| 909 | +118 |
-
+ #' @export |
||
| 910 | -1x | +|||
| 119 | +
- w_txt <- sapply(1:64, function(x) {
+ s_compare.factor <- function(x, |
|||
| 911 | -64x | +|||
| 120 | +
- graphics::par(ps = x)+ .ref_group, |
|||
| 912 | -64x | +|||
| 121 | +
- graphics::strwidth(w[4], units = "in")+ .in_ref_col, |
|||
| 913 | +122 |
- })+ denom = "n", |
||
| 914 | -1x | +|||
| 123 | +
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ na.rm = TRUE, # nolint |
|||
| 915 | +124 |
-
+ ...) {
|
||
| 916 | -1x | +125 | +16x |
- h_txt <- sapply(1:64, function(x) {
+ checkmate::assert_flag(.in_ref_col) |
| 917 | -64x | +126 | +16x |
- graphics::par(ps = x)+ assert_valid_factor(x) |
| 918 | -64x | -
- graphics::strheight(grid::stringHeight("X"), units = "in")
- |
- ||
| 919 | -+ | 127 | +16x |
- })+ assert_valid_factor(.ref_group) |
| 920 | -1x | +128 | +16x |
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ denom <- match.arg(denom) |
| 921 | +129 | |||
| 922 | -1x | +130 | +16x |
- if (ttheme$core$fg_params$fontsize == 12) {
+ y <- s_summary.factor( |
| 923 | -1x | +131 | +16x |
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ x = x, |
| 924 | -1x | +132 | +16x |
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ denom = denom, |
| 925 | -1x | +133 | +16x |
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ na.rm = na.rm, |
| 926 | +134 |
- }+ ... |
||
| 927 | +135 | - - | -||
| 928 | -1x | -
- gt <- gridExtra::tableGrob(+ ) |
||
| 929 | -1x | +|||
| 136 | +
- d = data,+ |
|||
| 930 | -1x | -
- theme = ttheme- |
- ||
| 931 | -+ | 137 | +16x |
- )+ if (na.rm) {
|
| 932 | -1x | +138 | +14x |
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
| 933 | -1x | +139 | +14x |
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
|
| 934 | +140 |
-
+ } else {
|
||
| 935 | -1x | +141 | +2x |
- vp <- grid::viewport(+ x <- x %>% explicit_na(label = "NA") |
| 936 | -1x | +142 | +2x |
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ .ref_group <- .ref_group %>% explicit_na(label = "NA") |
| 937 | -1x | +|||
| 143 | +
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ } |
|||
| 938 | -1x | +|||
| 144 | +
- height = height,+ |
|||
| 939 | +145 | 1x |
- width = width,+ if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
|
|
| 940 | -1x | -
- just = c("right", "top")
- |
- ||
| 941 | -+ | 146 | +16x |
- )+ checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2) |
| 942 | +147 | |||
| 943 | -1x | +148 | +16x |
- grid::gList(+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
| 944 | -1x | +149 | +13x |
- grid::gTree(+ tab <- rbind(table(x), table(.ref_group)) |
| 945 | -1x | +150 | +13x |
- vp = vp,+ res <- suppressWarnings(stats::chisq.test(tab)) |
| 946 | -1x | +151 | +13x |
- children = grid::gList(gt)+ res$p.value |
| 947 | +152 |
- )+ } else {
|
||
| 948 | -+ | |||
| 153 | +3x |
- )+ character() |
||
| 949 | +154 |
- }+ } |
||
| 950 | +155 | |||
| 951 | -+ | |||
| 156 | +16x |
- #' Helper function to create grid object with y-axis annotation+ y |
||
| 952 | +157 |
- #'+ } |
||
| 953 | +158 |
- #' @description `r lifecycle::badge("deprecated")`
+
|
||
| 954 | +159 |
- #'+ #' @describeIn compare_variables Method for `character` class. This makes an automatic |
||
| 955 | +160 |
- #' Build the y-axis annotation from a decomposed `ggplot`.+ #' conversion to `factor` (with a warning) and then forwards to the method for factors. |
||
| 956 | +161 |
#' |
||
| 957 | +162 |
- #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`.+ #' @param verbose (`flag`)\cr whether warnings and messages should be printed. Mainly used |
||
| 958 | +163 |
- #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`.+ #' to print out information about factor casting. Defaults to `TRUE`. |
||
| 959 | +164 |
#' |
||
| 960 | +165 |
- #' @return A `gTree` object containing the y-axis annotation from a `ggplot`.+ #' @method s_compare character |
||
| 961 | +166 |
#' |
||
| 962 | +167 |
#' @examples |
||
| 963 | +168 |
- #' \donttest{
+ #' # `s_compare.character` |
||
| 964 | +169 |
- #' library(dplyr)+ #' |
||
| 965 | +170 |
- #' library(survival)+ #' ## Basic usage: |
||
| 966 | +171 |
- #' library(grid)+ #' x <- c("a", "a", "b", "c", "a")
|
||
| 967 | +172 |
- #'+ #' y <- c("a", "b", "c")
|
||
| 968 | +173 |
- #' fit_km <- tern_ex_adtte %>%+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE) |
||
| 969 | +174 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 970 | +175 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' ## Note that missing values handling can make a large difference: |
||
| 971 | +176 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' x <- c("a", "a", "b", "c", "a", NA)
|
||
| 972 | +177 |
- #' xticks <- h_xticks(data = data_plot)+ #' y <- c("a", "b", "c", rep(NA, 20))
|
||
| 973 | +178 |
- #' gg <- h_ggkm(+ #' s_compare(x, |
||
| 974 | +179 |
- #' data = data_plot,+ #' .ref_group = y, .in_ref_col = FALSE, |
||
| 975 | +180 |
- #' censor_show = TRUE,+ #' .var = "x", verbose = FALSE |
||
| 976 | +181 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ #' ) |
||
| 977 | +182 |
- #' title = "title", footnotes = "footnotes", yval = "Survival"+ #' s_compare(x, |
||
| 978 | +183 |
- #' )+ #' .ref_group = y, .in_ref_col = FALSE, .var = "x", |
||
| 979 | +184 |
- #'+ #' na.rm = FALSE, verbose = FALSE |
||
| 980 | +185 |
- #' g_el <- h_decompose_gg(gg)+ #' ) |
||
| 981 | +186 |
#' |
||
| 982 | +187 |
- #' grid::grid.newpage()+ #' @export |
||
| 983 | +188 |
- #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20))+ s_compare.character <- function(x, |
||
| 984 | +189 |
- #' pushViewport(pvp)+ .ref_group, |
||
| 985 | +190 |
- #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis))+ .in_ref_col, |
||
| 986 | +191 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA))+ denom = "n", |
||
| 987 | +192 |
- #' }+ na.rm = TRUE, # nolint |
||
| 988 | +193 |
- #'+ .var, |
||
| 989 | +194 |
- #' @export+ verbose = TRUE, |
||
| 990 | +195 |
- h_grob_y_annot <- function(ylab, yaxis) {
- |
- ||
| 991 | -1x | -
- lifecycle::deprecate_warn(- |
- ||
| 992 | -1x | -
- "0.9.4",+ ...) {
|
||
| 993 | -1x | +196 | +2x |
- "h_grob_y_annot()",+ x <- as_factor_keep_attributes(x, verbose = verbose) |
| 994 | -1x | -
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."- |
- ||
| 995 | -+ | 197 | +2x |
- )+ .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose) |
| 996 | -1x | +198 | +2x |
- grid::gList(+ s_compare( |
| 997 | -1x | +199 | +2x |
- grid::gTree(+ x = x, |
| 998 | -1x | +200 | +2x |
- vp = grid::viewport(+ .ref_group = .ref_group, |
| 999 | -1x | +201 | +2x |
- width = grid::convertX(yaxis$widths + ylab$widths, "pt"),+ .in_ref_col = .in_ref_col, |
| 1000 | -1x | +202 | +2x |
- x = grid::unit(1, "npc"),+ denom = denom, |
| 1001 | -1x | +203 | +2x |
- just = "right"+ na.rm = na.rm, |
| 1002 | +204 |
- ),- |
- ||
| 1003 | -1x | -
- children = grid::gList(cbind(ylab, yaxis))+ ... |
||
| 1004 | +205 |
- )+ ) |
||
| 1005 | +206 |
- )+ } |
||
| 1006 | +207 |
- }+ |
||
| 1007 | +208 |
-
+ #' @describeIn compare_variables Method for `logical` class. A chi-squared test |
||
| 1008 | +209 |
- #' Helper function to create Cox-PH grobs+ #' is used. If missing values are not removed, then they are counted as `FALSE`. |
||
| 1009 | +210 |
#' |
||
| 1010 | +211 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @method s_compare logical |
||
| 1011 | +212 |
#' |
||
| 1012 | +213 |
- #' Grob of `rtable` output from [h_tbl_coxph_pairwise()]+ #' @examples |
||
| 1013 | +214 |
- #'+ #' # `s_compare.logical` |
||
| 1014 | +215 |
- #' @inheritParams h_grob_median_surv+ #' |
||
| 1015 | +216 |
- #' @param ... arguments to pass to [h_tbl_coxph_pairwise()].+ #' ## Basic usage: |
||
| 1016 | +217 |
- #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location.+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
||
| 1017 | +218 |
- #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location.+ #' y <- c(FALSE, FALSE, TRUE) |
||
| 1018 | +219 |
- #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob.+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE) |
||
| 1019 | +220 |
#' |
||
| 1020 | +221 |
- #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ #' ## Management of NA values. |
||
| 1021 | +222 |
- #' and `p-value (log-rank)`.+ #' x <- c(NA, TRUE, FALSE) |
||
| 1022 | +223 |
- #'+ #' y <- c(NA, NA, NA, NA, FALSE) |
||
| 1023 | +224 |
- #' @examples+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
||
| 1024 | +225 |
- #' \donttest{
+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
||
| 1025 | +226 |
- #' library(dplyr)+ #' |
||
| 1026 | +227 |
- #' library(survival)+ #' @export |
||
| 1027 | +228 |
- #' library(grid)+ s_compare.logical <- function(x, |
||
| 1028 | +229 |
- #'+ .ref_group, |
||
| 1029 | +230 |
- #' grid::grid.newpage()+ .in_ref_col, |
||
| 1030 | +231 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ na.rm = TRUE, # nolint |
||
| 1031 | +232 |
- #' data <- tern_ex_adtte %>%+ denom = "n", |
||
| 1032 | +233 |
- #' filter(PARAMCD == "OS") %>%+ ...) {
|
||
| 1033 | -+ | |||
| 234 | +4x |
- #' mutate(is_event = CNSR == 0)+ denom <- match.arg(denom) |
||
| 1034 | +235 |
- #' tbl_grob <- h_grob_coxph(+ |
||
| 1035 | -+ | |||
| 236 | +4x |
- #' df = data,+ y <- s_summary.logical( |
||
| 1036 | -+ | |||
| 237 | +4x |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"),+ x = x, |
||
| 1037 | -+ | |||
| 238 | +4x |
- #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5+ na.rm = na.rm, |
||
| 1038 | -+ | |||
| 239 | +4x |
- #' )+ denom = denom, |
||
| 1039 | +240 |
- #' grid::grid.draw(tbl_grob)+ ... |
||
| 1040 | +241 |
- #' }+ ) |
||
| 1041 | +242 |
- #'+ |
||
| 1042 | -+ | |||
| 243 | +4x |
- #' @export+ if (na.rm) {
|
||
| 1043 | -+ | |||
| 244 | +3x |
- h_grob_coxph <- function(...,+ x <- stats::na.omit(x) |
||
| 1044 | -+ | |||
| 245 | +3x |
- x = 0,+ .ref_group <- stats::na.omit(.ref_group) |
||
| 1045 | +246 |
- y = 0,+ } else {
|
||
| 1046 | -+ | |||
| 247 | +1x |
- width = grid::unit(0.4, "npc"),+ x[is.na(x)] <- FALSE |
||
| 1047 | -+ | |||
| 248 | +1x |
- ttheme = gridExtra::ttheme_default(+ .ref_group[is.na(.ref_group)] <- FALSE |
||
| 1048 | +249 |
- padding = grid::unit(c(1, .5), "lines"),+ } |
||
| 1049 | +250 |
- core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+
|
||
| 1050 | -+ | |||
| 251 | +4x |
- )) {
+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
||
| 1051 | -1x | +252 | +4x |
- lifecycle::deprecate_warn(+ x <- factor(x, levels = c(TRUE, FALSE)) |
| 1052 | -1x | +253 | +4x |
- "0.9.4",+ .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE)) |
| 1053 | -1x | +254 | +4x |
- "h_grob_coxph()",+ tbl <- rbind(table(x), table(.ref_group)) |
| 1054 | -1x | +255 | +4x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ suppressWarnings(prop_chisq(tbl)) |
| 1055 | +256 |
- )+ } else {
|
||
| 1056 | -1x | +|||
| 257 | +! |
- data <- h_tbl_coxph_pairwise(...)+ character() |
||
| 1057 | +258 |
-
+ } |
||
| 1058 | -1x | +|||
| 259 | +
- width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ |
|||
| 1059 | -1x | +260 | +4x |
- height <- width * (nrow(data) + 1) / 12+ y |
| 1060 | +261 |
-
+ } |
||
| 1061 | -1x | +|||
| 262 | +
- w <- paste(" ", c(
+
|
|||
| 1062 | -1x | +|||
| 263 | +
- rownames(data)[which.max(nchar(rownames(data)))],+ #' @describeIn compare_variables Layout-creating function which can take statistics function arguments |
|||
| 1063 | -1x | +|||
| 264 | +
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 1064 | +265 |
- ))+ #' |
||
| 1065 | -1x | +|||
| 266 | +
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ #' @param ... arguments passed to `s_compare()`. |
|||
| 1066 | +267 |
-
+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 1067 | -1x | +|||
| 268 | +
- w_txt <- sapply(1:64, function(x) {
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 1068 | -64x | +|||
| 269 | +
- graphics::par(ps = x)+ #' for that statistic's row label. |
|||
| 1069 | -64x | +|||
| 270 | +
- graphics::strwidth(w[4], units = "in")+ #' |
|||
| 1070 | +271 |
- })+ #' @return |
||
| 1071 | -1x | +|||
| 272 | +
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions, |
|||
| 1072 | +273 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 1073 | -1x | +|||
| 274 | +
- h_txt <- sapply(1:64, function(x) {
+ #' the statistics from `s_compare()` to the table layout. |
|||
| 1074 | -64x | +|||
| 275 | +
- graphics::par(ps = x)+ #' |
|||
| 1075 | -64x | +|||
| 276 | +
- graphics::strheight(grid::stringHeight("X"), units = "in")
+ #' @examples |
|||
| 1076 | +277 |
- })+ #' # `compare_vars()` in `rtables` pipelines |
||
| 1077 | -1x | +|||
| 278 | +
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ #' |
|||
| 1078 | +279 |
-
+ #' ## Default output within a `rtables` pipeline. |
||
| 1079 | -1x | +|||
| 280 | +
- if (ttheme$core$fg_params$fontsize == 12) {
+ #' lyt <- basic_table() %>% |
|||
| 1080 | -1x | +|||
| 281 | +
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
|
|||
| 1081 | -1x | +|||
| 282 | +
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' compare_vars(c("AGE", "SEX"))
|
|||
| 1082 | -1x | +|||
| 283 | +
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' build_table(lyt, tern_ex_adsl) |
|||
| 1083 | +284 |
- }+ #' |
||
| 1084 | +285 |
-
+ #' ## Select and format statistics output. |
||
| 1085 | -1x | +|||
| 286 | +
- tryCatch(+ #' lyt <- basic_table() %>% |
|||
| 1086 | -1x | +|||
| 287 | +
- expr = {
+ #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
|
|||
| 1087 | -1x | +|||
| 288 | +
- gt <- gridExtra::tableGrob(+ #' compare_vars( |
|||
| 1088 | -1x | +|||
| 289 | +
- d = data,+ #' vars = "AGE", |
|||
| 1089 | -1x | +|||
| 290 | +
- theme = ttheme+ #' .stats = c("mean_sd", "pval"),
|
|||
| 1090 | -1x | +|||
| 291 | +
- ) # ERROR 'data' must be of a vector type, was 'NULL'+ #' .formats = c(mean_sd = "xx.x, xx.x"), |
|||
| 1091 | -1x | +|||
| 292 | +
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ #' .labels = c(mean_sd = "Mean, SD") |
|||
| 1092 | -1x | +|||
| 293 | +
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ #' ) |
|||
| 1093 | -1x | +|||
| 294 | +
- vp <- grid::viewport(+ #' build_table(lyt, df = tern_ex_adsl) |
|||
| 1094 | -1x | +|||
| 295 | +
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ #' |
|||
| 1095 | -1x | +|||
| 296 | +
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ #' @export |
|||
| 1096 | -1x | +|||
| 297 | +
- height = height,+ #' @order 2 |
|||
| 1097 | -1x | +|||
| 298 | +
- width = width,+ compare_vars <- function(lyt, |
|||
| 1098 | -1x | +|||
| 299 | +
- just = c("left", "bottom")
+ vars, |
|||
| 1099 | +300 |
- )+ var_labels = vars, |
||
| 1100 | -1x | +|||
| 301 | +
- grid::gList(+ na_str = default_na_str(), |
|||
| 1101 | -1x | +|||
| 302 | +
- grid::gTree(+ nested = TRUE, |
|||
| 1102 | -1x | +|||
| 303 | +
- vp = vp,+ ..., |
|||
| 1103 | -1x | +|||
| 304 | +
- children = grid::gList(gt)+ na.rm = TRUE, # nolint |
|||
| 1104 | +305 |
- )+ show_labels = "default", |
||
| 1105 | +306 |
- )+ table_names = vars, |
||
| 1106 | +307 |
- },+ section_div = NA_character_,+ |
+ ||
| 308 | ++ |
+ .stats = c("n", "mean_sd", "count_fraction", "pval"),
+ |
+ ||
| 309 | ++ |
+ .formats = NULL,+ |
+ ||
| 310 | ++ |
+ .labels = NULL,+ |
+ ||
| 311 | ++ |
+ .indent_mods = NULL) {
|
||
| 1107 | -1x | +312 | +4x |
- error = function(w) {
+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...) |
| 1108 | -! | +|||
| 313 | +
- message(paste(+ |
|||
| 1109 | -! | +|||
| 314 | +1x |
- "Warning: Cox table will not be displayed as there is",+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ |
+ ||
| 315 | +1x | +
+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
||
| 1110 | +316 | ! |
- "not any level to be compared in the arm variable."+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
|
| 1111 | +317 |
- ))+ |
||
| 1112 | -! | +|||
| 318 | +4x |
- return(+ analyze( |
||
| 1113 | -! | +|||
| 319 | +4x |
- grid::gList(+ lyt = lyt, |
||
| 1114 | -! | +|||
| 320 | +4x |
- grid::gTree(+ vars = vars, |
||
| 1115 | -! | +|||
| 321 | +4x |
- vp = NULL,+ var_labels = var_labels, |
||
| 1116 | -! | +|||
| 322 | +4x |
- children = NULL+ afun = a_summary, |
||
| 1117 | -+ | |||
| 323 | +4x |
- )+ na_str = na_str, |
||
| 1118 | -+ | |||
| 324 | +4x |
- )+ nested = nested, |
||
| 1119 | -+ | |||
| 325 | +4x |
- )+ extra_args = extra_args, |
||
| 1120 | -+ | |||
| 326 | +4x |
- }+ inclNAs = TRUE,+ |
+ ||
| 327 | +4x | +
+ show_labels = show_labels,+ |
+ ||
| 328 | +4x | +
+ table_names = table_names,+ |
+ ||
| 329 | +4x | +
+ section_div = section_div |
||
| 1121 | +330 |
) |
||
| 1122 | +331 |
}@@ -7972,14 +7998,14 @@ tern coverage - 95.65% |
| 1 |
- #' Helper function to create a new SMQ variable in ADAE by stacking SMQ and/or CQ records.+ #' Count patients with toxicity grades that have worsened from baseline by highest grade post-baseline |
||
| 5 |
- #' Helper function to create a new SMQ variable in ADAE that consists of all adverse events belonging to+ #' The analyze function [count_abnormal_lab_worsen_by_baseline()] creates a layout element to count patients with |
||
| 6 |
- #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events+ #' analysis toxicity grades which have worsened from baseline, categorized by highest (worst) grade post-baseline. |
||
| 7 |
- #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing+ #' |
||
| 8 |
- #' done with [df_explicit_na()] to have the desired output.+ #' This function analyzes primary analysis variable `var` which indicates analysis toxicity grades. Additional |
||
| 9 |
- #'+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to `USUBJID`), |
||
| 10 |
- #' @inheritParams argument_convention+ #' a variable to indicate unique subject identifiers, `baseline_var` (defaults to `BTOXGR`), a variable to indicate |
||
| 11 |
- #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries.+ #' baseline toxicity grades, and `direction_var` (defaults to `GRADDIR`), a variable to indicate toxicity grade |
||
| 12 |
- #' @param smq_varlabel (`string`)\cr a label for the new variable created.+ #' directions of interest to include (e.g. `"H"` (high), `"L"` (low), or `"B"` (both)). |
||
| 13 |
- #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created.+ #' |
||
| 14 |
- #' @param aag_summary (`data.frame`)\cr containing the SMQ baskets and the levels of interest for the final SMQ+ #' For the direction(s) specified in `direction_var`, patient counts by worst grade for patients who have |
||
| 15 |
- #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset.+ #' worsened from baseline are calculated as follows: |
||
| 16 |
- #' The two columns of this dataset should be named `basket` and `basket_name`.+ #' * `1` to `4`: The number of patients who have worsened from their baseline grades with worst |
||
| 17 |
- #'+ #' grades 1-4, respectively. |
||
| 18 |
- #' @return A `data.frame` with variables in `keys` taken from `df` and new variable SMQ containing+ #' * `Any`: The total number of patients who have worsened from their baseline grades. |
||
| 19 |
- #' records belonging to the baskets selected via the `baskets` argument.+ #' |
||
| 20 |
- #'+ #' Fractions are calculated by dividing the above counts by the number of patients who's analysis toxicity grades |
||
| 21 |
- #' @examples+ #' have worsened from baseline toxicity grades during treatment. |
||
| 22 |
- #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na()+ #' |
||
| 23 |
- #' h_stack_by_baskets(df = adae)+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create a row |
||
| 24 |
- #'+ #' split on variable `direction_var`. |
||
| 25 |
- #' aag <- data.frame(+ #' |
||
| 26 |
- #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
+ #' @inheritParams argument_convention |
||
| 27 |
- #' REFNAME = c(+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables including: |
||
| 28 |
- #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi",+ #' * `id` (`string`)\cr subject variable name. |
||
| 29 |
- #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi"+ #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable. |
||
| 30 |
- #' ),+ #' * `direction_var` (`string`)\cr see `direction_var` for more details. |
||
| 31 |
- #' SCOPE = c("", "", "BROAD", "BROAD"),
+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 32 |
- #' stringsAsFactors = FALSE+ #' |
||
| 33 |
- #' )+ #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade_worsen"))``
|
||
| 35 |
- #' basket_name <- character(nrow(aag))+ #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] which are used within |
||
| 36 |
- #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
+ #' [s_count_abnormal_lab_worsen_by_baseline()] to process input data. |
||
| 37 |
- #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
+ #' |
||
| 38 |
- #' basket_name[cq_pos] <- aag$REFNAME[cq_pos]+ #' @name abnormal_by_worst_grade_worsen |
||
| 39 |
- #' basket_name[smq_pos] <- paste0(+ #' @order 1 |
||
| 40 |
- #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
+ NULL |
||
| 41 |
- #' )+ |
||
| 42 |
- #'+ #' Helper function to prepare ADLB with worst labs |
||
| 43 |
- #' aag_summary <- data.frame(+ #' |
||
| 44 |
- #' basket = aag$NAMVAR,+ #' @description `r lifecycle::badge("stable")`
|
||
| 45 |
- #' basket_name = basket_name,+ #' |
||
| 46 |
- #' stringsAsFactors = TRUE+ #' Helper function to prepare a `df` for generate the patient count shift table. |
||
| 47 |
- #' )+ #' |
||
| 48 |
- #'+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 49 |
- #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)+ #' @param worst_flag_low (named `vector`)\cr worst low post-baseline lab grade flag variable. See how this is |
||
| 50 |
- #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ #' implemented in the following examples. |
||
| 51 |
- #'+ #' @param worst_flag_high (named `vector`)\cr worst high post-baseline lab grade flag variable. See how this is |
||
| 52 |
- #' h_stack_by_baskets(+ #' implemented in the following examples. |
||
| 53 |
- #' df = adae,+ #' @param direction_var (`string`)\cr name of the direction variable specifying the direction of the shift table of |
||
| 54 |
- #' aag_summary = NULL,+ #' interest. Only lab records flagged by `L`, `H` or `B` are included in the shift table. |
||
| 55 |
- #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
+ #' * `L`: low direction only |
||
| 56 |
- #' baskets = "SMQ01NAM"+ #' * `H`: high direction only |
||
| 57 |
- #' )+ #' * `B`: both low and high directions |
||
| 59 |
- #' @export+ #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the |
||
| 60 |
- h_stack_by_baskets <- function(df,+ #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the |
||
| 61 |
- baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
+ #' direction specified according to `direction_var`. For instance, for a lab that is |
||
| 62 |
- smq_varlabel = "Standardized MedDRA Query",+ #' needed for the low direction only, only records flagged by `worst_flag_low` are |
||
| 63 |
- keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
+ #' selected. For a lab that is needed for both low and high directions, the worst |
||
| 64 |
- aag_summary = NULL,+ #' low records are selected for the low direction, and the worst high record are selected |
||
| 65 |
- na_str = "<Missing>") {
+ #' for the high direction. |
||
| 66 | -5x | +
- smq_nam <- baskets[startsWith(baskets, "SMQ")]+ #' |
|
| 67 |
- # SC corresponding to NAM+ #' @seealso [abnormal_by_worst_grade_worsen] |
||
| 68 | -5x | +
- smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)+ #' |
|
| 69 | -5x | +
- smq <- stats::setNames(smq_sc, smq_nam)+ #' @examples |
|
| 70 |
-
+ #' library(dplyr) |
||
| 71 | -5x | +
- checkmate::assert_character(baskets)+ #' |
|
| 72 | -5x | +
- checkmate::assert_string(smq_varlabel)+ #' # The direction variable, GRADDR, is based on metadata |
|
| 73 | -5x | +
- checkmate::assert_data_frame(df)+ #' adlb <- tern_ex_adlb %>% |
|
| 74 | -5x | +
- checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))+ #' mutate( |
|
| 75 | -4x | +
- checkmate::assert_true(all(endsWith(baskets, "NAM")))+ #' GRADDR = case_when( |
|
| 76 | -3x | +
- checkmate::assert_subset(baskets, names(df))+ #' PARAMCD == "ALT" ~ "B", |
|
| 77 | -3x | +
- checkmate::assert_subset(keys, names(df))+ #' PARAMCD == "CRP" ~ "L", |
|
| 78 | -3x | +
- checkmate::assert_subset(smq_sc, names(df))+ #' PARAMCD == "IGA" ~ "H" |
|
| 79 | -3x | +
- checkmate::assert_string(na_str)+ #' ) |
|
| 80 |
-
+ #' ) %>% |
||
| 81 | -3x | +
- if (!is.null(aag_summary)) {
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|
| 82 | -1x | +
- assert_df_with_variables(+ #' |
|
| 83 | -1x | +
- df = aag_summary,+ #' df <- h_adlb_worsen( |
|
| 84 | -1x | +
- variables = list(val = c("basket", "basket_name"))
+ #' adlb, |
|
| 85 |
- )+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 86 |
- # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 87 |
- # Honestly, I think those should completely match. Target baskets should be the same.+ #' direction_var = "GRADDR" |
||
| 88 | -1x | +
- if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
+ #' ) |
|
| 89 | -! | +
- warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
+ #' |
|
| 90 |
- }+ #' @export |
||
| 91 |
- }+ h_adlb_worsen <- function(adlb, |
||
| 92 |
-
+ worst_flag_low = NULL, |
||
| 93 | -3x | +
- var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)+ worst_flag_high = NULL, |
|
| 94 |
-
+ direction_var) {
|
||
| 95 | -+ | 5x |
- # convert `na_str` records from baskets to NA for the later loop and from wide to long steps+ checkmate::assert_string(direction_var) |
| 96 | -3x | +5x |
- df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA+ checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
|
| 97 | -+ | 5x |
-
+ assert_df_with_variables(adlb, list("Col" = direction_var))
|
| 98 | -3x | +
- if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
+
|
|
| 99 | -1x | +5x |
- df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty data frame keeping all factor levels+ if (any(unique(adlb[[direction_var]]) == "H")) {
|
| 100 | -+ | 4x |
- } else {
+ assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
|
| 101 |
- # Concatenate SMQxxxNAM with corresponding SMQxxxSC+ } |
||
| 102 | -2x | +
- df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]+ |
|
| 103 | -+ | 5x |
-
+ if (any(unique(adlb[[direction_var]]) == "L")) {
|
| 104 | -2x | +4x |
- for (nam in names(smq)) {
+ assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
|
| 105 | -4x | +
- sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ } |
|
| 106 | -4x | +
- nam_notna <- !is.na(df[[nam]])+ |
|
| 107 | -4x | +5x |
- new_colname <- paste(nam, sc, sep = "_")+ if (any(unique(adlb[[direction_var]]) == "B")) {
|
| 108 | -4x | +3x |
- df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
+ assert_df_with_variables( |
| 109 | -+ | 3x |
- }+ adlb, |
| 110 | -+ | 3x |
-
+ list( |
| 111 | -2x | +3x |
- df_cnct$unique_id <- seq(1, nrow(df_cnct))+ "Low" = names(worst_flag_low), |
| 112 | -2x | +3x |
- var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))]+ "High" = names(worst_flag_high) |
| 113 |
- # have to convert df_cnct from tibble to data frame+ ) |
||
| 114 |
- # as it throws a warning otherwise about rownames.+ ) |
||
| 115 |
- # tibble do not support rownames and reshape creates rownames+ } |
||
| 117 | -2x | +
- df_long <- stats::reshape(+ # extract patients with worst post-baseline lab, either low or high or both |
|
| 118 | -2x | +5x |
- data = as.data.frame(df_cnct),+ worst_flag <- c(worst_flag_low, worst_flag_high) |
| 119 | -2x | +5x |
- varying = var_cols,+ col_names <- names(worst_flag) |
| 120 | -2x | +5x |
- v.names = "SMQ",+ filter_values <- worst_flag |
| 121 | -2x | +5x |
- idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ temp <- Map( |
| 122 | -2x | +5x |
- direction = "long",+ function(x, y) which(adlb[[x]] == y), |
| 123 | -2x | +5x |
- new.row.names = seq(prod(length(var_cols), nrow(df_cnct)))+ col_names, |
| 124 | -+ | 5x |
- )+ filter_values |
| 125 |
-
+ ) |
||
| 126 | -2x | +5x |
- df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
+ position_satisfy_filters <- Reduce(union, temp) |
| 127 | -2x | +
- df_long$SMQ <- as.factor(df_long$SMQ)+ |
|
| 128 |
- }+ # select variables of interest |
||
| 129 | -+ | 5x |
-
+ adlb_f <- adlb[position_satisfy_filters, ] |
| 130 | -3x | +
- smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str)+ |
|
| 131 |
-
+ # generate subsets for different directionality |
||
| 132 | -3x | +5x |
- if (!is.null(aag_summary)) {
+ adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ] |
| 133 | -+ | 5x |
- # A warning in case there is no match between df and aag_summary records+ adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ] |
| 134 | -1x | +5x |
- if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
+ adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ] |
| 135 | -1x | +
- warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
+
|
|
| 136 |
- }+ # for labs requiring both high and low, data is duplicated and will be stacked on top of each other |
||
| 137 | -1x | +5x |
- df_long[["SMQ"]] <- factor(+ adlb_f_b_h <- adlb_f_b |
| 138 | -1x | +5x |
- df_long[["SMQ"]],+ adlb_f_b_l <- adlb_f_b |
| 139 | -1x | +
- levels = sort(+ |
|
| 140 | -1x | +
- c(+ # extract data with worst lab |
|
| 141 | -1x | +5x |
- smq_levels,+ if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
|
| 142 | -1x | +
- setdiff(unique(aag_summary$basket_name), smq_levels)+ # change H to High, L to Low |
|
| 143 | -+ | 3x |
- )+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
| 144 | -+ | 3x |
- )+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
| 145 |
- )+ |
||
| 146 |
- } else {
+ # change, B to High and Low |
||
| 147 | -2x | +3x |
- all_na_basket_flag <- vapply(df[, baskets], function(x) {
+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
| 148 | -6x | +3x |
- all(is.na(x))+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
| 149 | -2x | +
- }, FUN.VALUE = logical(1))+ |
|
| 150 | -2x | +3x |
- all_na_basket <- baskets[all_na_basket_flag]+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
| 151 | -+ | 3x |
-
+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
| 152 | -2x | +3x |
- df_long[["SMQ"]] <- factor(+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
| 153 | -2x | +3x |
- df_long[["SMQ"]],+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
| 154 | -2x | +
- levels = sort(c(smq_levels, all_na_basket))+ |
|
| 155 | -+ | 3x |
- )+ out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l) |
| 156 | -+ | 2x |
- }+ } else if (!is.null(worst_flag_high)) {
|
| 157 | -3x | +1x |
- formatters::var_labels(df_long) <- var_labels+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
| 158 | -3x | +1x |
- tibble::tibble(df_long)+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
| 159 |
- }+ |
| 1 | -+ | |||
| 160 | +1x |
- #' Count specific values+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 2 | -+ | |||
| 161 | +1x |
- #'+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 3 | +162 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 163 | +1x |
- #'+ out <- rbind(adlb_out_h, adlb_out_b_h) |
||
| 5 | -+ | |||
| 164 | +1x |
- #' The analyze function [count_values()] creates a layout element to calculate counts of specific values within a+ } else if (!is.null(worst_flag_low)) {
|
||
| 6 | -+ | |||
| 165 | +1x |
- #' variable of interest.+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
||
| 7 | -+ | |||
| 166 | +1x |
- #'+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
||
| 8 | +167 |
- #' This function analyzes one or more variables of interest supplied as a vector to `vars`. Values to+ |
||
| 9 | -+ | |||
| 168 | +1x |
- #' count for variable(s) in `vars` can be given as a vector via the `values` argument. One row of+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 10 | -+ | |||
| 169 | +1x |
- #' counts will be generated for each variable.+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 11 | +170 |
- #'+ |
||
| 12 | -+ | |||
| 171 | +1x |
- #' @inheritParams argument_convention+ out <- rbind(adlb_out_l, adlb_out_b_l) |
||
| 13 | +172 |
- #' @param values (`character`)\cr specific values that should be counted.+ } |
||
| 14 | +173 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ |
||
| 15 | +174 |
- #'+ # label |
||
| 16 | -+ | |||
| 175 | +5x |
- #' Options are: ``r shQuote(get_stats("count_values"))``
+ formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE) |
||
| 17 | +176 |
- #'+ # NA |
||
| 18 | -+ | |||
| 177 | +5x |
- #' @note+ out |
||
| 19 | +178 |
- #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x`+ } |
||
| 20 | -- |
- #' and fails otherwise.- |
- ||
| 21 | +179 |
- #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`,+ |
||
| 22 | +180 |
- #' otherwise they are hidden.+ #' Helper function to analyze patients for `s_count_abnormal_lab_worsen_by_baseline()` |
||
| 23 | +181 |
#' |
||
| 24 | +182 |
- #' @name count_values+ #' @description `r lifecycle::badge("stable")`
|
||
| 25 | +183 |
- #' @order 1+ #' |
||
| 26 | +184 |
- NULL+ #' Helper function to count the number of patients and the fraction of patients according to |
||
| 27 | +185 |
-
+ #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`, |
||
| 28 | +186 |
- #' @describeIn count_values S3 generic function to count values.+ #' and the direction of interest specified in `direction_var`. |
||
| 29 | +187 |
#' |
||
| 30 | +188 |
- #' @inheritParams s_summary.logical+ #' @inheritParams argument_convention |
||
| 31 | +189 |
- #'+ #' @inheritParams h_adlb_worsen |
||
| 32 | +190 |
- #' @return+ #' @param baseline_var (`string`)\cr name of the baseline lab grade variable. |
||
| 33 | +191 |
- #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable.+ #' |
||
| 34 | +192 |
- #'+ #' @return The counts and fraction of patients |
||
| 35 | +193 |
- #' @export+ #' whose worst post-baseline lab grades are worse than their baseline grades, for |
||
| 36 | +194 |
- s_count_values <- function(x,+ #' post-baseline worst grades "1", "2", "3", "4" and "Any". |
||
| 37 | +195 |
- values,+ #' |
||
| 38 | +196 |
- na.rm = TRUE, # nolint+ #' @seealso [abnormal_by_worst_grade_worsen] |
||
| 39 | +197 |
- .N_col, # nolint+ #' |
||
| 40 | +198 |
- .N_row, # nolint+ #' @examples |
||
| 41 | +199 |
- denom = c("n", "N_col", "N_row")) {
+ #' library(dplyr) |
||
| 42 | -185x | +|||
| 200 | +
- UseMethod("s_count_values", x)
+ #' |
|||
| 43 | +201 |
- }+ #' # The direction variable, GRADDR, is based on metadata |
||
| 44 | +202 |
-
+ #' adlb <- tern_ex_adlb %>% |
||
| 45 | +203 |
- #' @describeIn count_values Method for `character` class.+ #' mutate( |
||
| 46 | +204 |
- #'+ #' GRADDR = case_when( |
||
| 47 | +205 |
- #' @method s_count_values character+ #' PARAMCD == "ALT" ~ "B", |
||
| 48 | +206 |
- #'+ #' PARAMCD == "CRP" ~ "L", |
||
| 49 | +207 |
- #' @examples+ #' PARAMCD == "IGA" ~ "H" |
||
| 50 | +208 |
- #' # `s_count_values.character`+ #' ) |
||
| 51 | +209 |
- #' s_count_values(x = c("a", "b", "a"), values = "a")
+ #' ) %>% |
||
| 52 | +210 |
- #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 53 | +211 |
#' |
||
| 54 | +212 |
- #' @export+ #' df <- h_adlb_worsen( |
||
| 55 | +213 |
- s_count_values.character <- function(x,+ #' adlb, |
||
| 56 | +214 |
- values = "Y",+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 57 | +215 |
- na.rm = TRUE, # nolint+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 58 | +216 |
- ...) {
+ #' direction_var = "GRADDR" |
||
| 59 | -183x | +|||
| 217 | +
- checkmate::assert_character(values)+ #' ) |
|||
| 60 | +218 |
-
+ #' |
||
| 61 | -183x | +|||
| 219 | +
- if (na.rm) {
+ #' # `h_worsen_counter` |
|||
| 62 | -182x | +|||
| 220 | +
- x <- x[!is.na(x)]+ #' h_worsen_counter( |
|||
| 63 | +221 |
- }+ #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"), |
||
| 64 | +222 |
-
+ #' id = "USUBJID", |
||
| 65 | -183x | +|||
| 223 | +
- is_in_values <- x %in% values+ #' .var = "ATOXGR", |
|||
| 66 | +224 |
-
+ #' baseline_var = "BTOXGR", |
||
| 67 | -183x | +|||
| 225 | +
- s_summary(is_in_values, ...)+ #' direction_var = "GRADDR" |
|||
| 68 | +226 |
- }+ #' ) |
||
| 69 | +227 |
-
+ #' |
||
| 70 | +228 |
- #' @describeIn count_values Method for `factor` class. This makes an automatic+ #' @export |
||
| 71 | +229 |
- #' conversion to `character` and then forwards to the method for characters.+ h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
|
||
| 72 | -+ | |||
| 230 | +17x |
- #'+ checkmate::assert_string(id) |
||
| 73 | -+ | |||
| 231 | +17x |
- #' @method s_count_values factor+ checkmate::assert_string(.var) |
||
| 74 | -+ | |||
| 232 | +17x |
- #'+ checkmate::assert_string(baseline_var) |
||
| 75 | -+ | |||
| 233 | +17x |
- #' @examples+ checkmate::assert_scalar(unique(df[[direction_var]])) |
||
| 76 | -+ | |||
| 234 | +17x |
- #' # `s_count_values.factor`+ checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
|
||
| 77 | -+ | |||
| 235 | +17x |
- #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
+ assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var))) |
||
| 78 | +236 |
- #'+ |
||
| 79 | +237 |
- #' @export+ # remove post-baseline missing |
||
| 80 | -+ | |||
| 238 | +17x |
- s_count_values.factor <- function(x,+ df <- df[df[[.var]] != "<Missing>", ] |
||
| 81 | +239 |
- values = "Y",+ |
||
| 82 | +240 |
- ...) {
+ # obtain directionality |
||
| 83 | -3x | +241 | +17x |
- s_count_values(as.character(x), values = as.character(values), ...)+ direction <- unique(df[[direction_var]]) |
| 84 | +242 |
- }+ |
||
| 85 | -+ | |||
| 243 | +17x |
-
+ if (direction == "Low") {
|
||
| 86 | -+ | |||
| 244 | +10x |
- #' @describeIn count_values Method for `logical` class.+ grade <- -1:-4 |
||
| 87 | -+ | |||
| 245 | +10x |
- #'+ worst_grade <- -4 |
||
| 88 | -+ | |||
| 246 | +7x |
- #' @method s_count_values logical+ } else if (direction == "High") {
|
||
| 89 | -+ | |||
| 247 | +7x |
- #'+ grade <- 1:4 |
||
| 90 | -+ | |||
| 248 | +7x |
- #' @examples+ worst_grade <- 4 |
||
| 91 | +249 |
- #' # `s_count_values.logical`+ } |
||
| 92 | +250 |
- #' s_count_values(x = c(TRUE, FALSE, TRUE))+ + |
+ ||
| 251 | +17x | +
+ if (nrow(df) > 0) {
+ |
+ ||
| 252 | +17x | +
+ by_grade <- lapply(grade, function(i) {
|
||
| 93 | +253 |
- #'+ # filter baseline values that is less than i or <Missing>+ |
+ ||
| 254 | +68x | +
+ df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ] |
||
| 94 | +255 |
- #' @export+ # num: number of patients with post-baseline worst lab equal to i+ |
+ ||
| 256 | +68x | +
+ num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE])) |
||
| 95 | +257 |
- s_count_values.logical <- function(x, values = TRUE, ...) {
+ # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction |
||
| 96 | -3x | +258 | +68x |
- checkmate::assert_logical(values)+ denom <- length(unique(df_temp[[id]])) |
| 97 | -3x | +259 | +68x |
- s_count_values(as.character(x), values = as.character(values), ...)+ rm(df_temp) |
| 98 | -+ | |||
| 260 | +68x |
- }+ c(num = num, denom = denom) |
||
| 99 | +261 |
-
+ }) |
||
| 100 | +262 |
- #' @describeIn count_values Formatted analysis function which is used as `afun`+ } else {
|
||
| 101 | -+ | |||
| 263 | +! |
- #' in `count_values()`.+ by_grade <- lapply(1, function(i) {
|
||
| 102 | -+ | |||
| 264 | +! |
- #'+ c(num = 0, denom = 0) |
||
| 103 | +265 |
- #' @return+ }) |
||
| 104 | +266 |
- #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
||
| 105 | +267 |
- #'+ |
||
| 106 | -+ | |||
| 268 | +17x |
- #' @examples+ names(by_grade) <- as.character(seq_along(by_grade)) |
||
| 107 | +269 |
- #' # `a_count_values`+ |
||
| 108 | +270 |
- #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
+ # baseline grade less 4 or missing |
||
| 109 | -+ | |||
| 271 | +17x |
- #'+ df_temp <- df[!df[[baseline_var]] %in% worst_grade, ] |
||
| 110 | +272 |
- #' @export+ |
||
| 111 | +273 |
- a_count_values <- make_afun(+ # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction |
||
| 112 | -+ | |||
| 274 | +17x |
- s_count_values,+ denom <- length(unique(df_temp[, id, drop = TRUE])) |
||
| 113 | +275 |
- .formats = c(count_fraction = "xx (xx.xx%)", count = "xx")+ |
||
| 114 | +276 |
- )+ # condition 1: missing baseline and in the direction of abnormality+ |
+ ||
| 277 | +17x | +
+ con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)+ |
+ ||
| 278 | +17x | +
+ df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ] |
||
| 115 | +279 | |||
| 116 | +280 |
- #' @describeIn count_values Layout-creating function which can take statistics function arguments+ # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline |
||
| 117 | -+ | |||
| 281 | +17x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ if (direction == "Low") {
|
||
| 118 | -+ | |||
| 282 | +10x |
- #'+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
||
| 119 | +283 |
- #' @return+ } else {
|
||
| 120 | -+ | |||
| 284 | +7x |
- #' * `count_values()` returns a layout object suitable for passing to further layouting functions,+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
||
| 121 | +285 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ } |
||
| 122 | +286 |
- #' the statistics from `s_count_values()` to the table layout.+ |
||
| 123 | +287 |
- #'+ # number of patients satisfy either conditions 1 or 2+ |
+ ||
| 288 | +17x | +
+ num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE])) |
||
| 124 | +289 |
- #' @examples+ + |
+ ||
| 290 | +17x | +
+ list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
|
||
| 125 | +291 |
- #' # `count_values`+ } |
||
| 126 | +292 |
- #' basic_table() %>%+ |
||
| 127 | +293 |
- #' count_values("Species", values = "setosa") %>%
+ #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline |
||
| 128 | +294 |
- #' build_table(iris)+ #' lab grades are worse than their baseline grades. |
||
| 129 | +295 |
#' |
||
| 130 | +296 |
- #' @export+ #' @return |
||
| 131 | +297 |
- #' @order 2+ #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst |
||
| 132 | +298 |
- count_values <- function(lyt,+ #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades |
||
| 133 | +299 |
- vars,+ #' "1", "2", "3", "4" and "Any". |
||
| 134 | +300 |
- values,+ #' |
||
| 135 | +301 |
- na_str = default_na_str(),+ #' @keywords internal |
||
| 136 | +302 |
- nested = TRUE,+ s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint |
||
| 137 | +303 |
- ...,+ .var = "ATOXGR", |
||
| 138 | +304 |
- table_names = vars,+ variables = list( |
||
| 139 | +305 |
- .stats = "count_fraction",+ id = "USUBJID", |
||
| 140 | +306 |
- .formats = NULL,+ baseline_var = "BTOXGR", |
||
| 141 | +307 |
- .labels = c(count_fraction = paste(values, collapse = ", ")),+ direction_var = "GRADDR" |
||
| 142 | +308 |
- .indent_mods = NULL) {
+ )) {
|
||
| 143 | -3x | -
- extra_args <- list(values = values, ...)- |
- ||
| 144 | -+ | 309 | +1x |
-
+ checkmate::assert_string(.var) |
| 145 | -3x | +310 | +1x |
- afun <- make_afun(+ checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
|
| 146 | -3x | +311 | +1x |
- a_count_values,+ checkmate::assert_string(variables$id) |
| 147 | -3x | +312 | +1x |
- .stats = .stats,+ checkmate::assert_string(variables$baseline_var) |
| 148 | -3x | +313 | +1x |
- .formats = .formats,+ checkmate::assert_string(variables$direction_var) |
| 149 | -3x | +314 | +1x |
- .labels = .labels,+ assert_df_with_variables(df, c(aval = .var, variables[1:3])) |
| 150 | -3x | +315 | +1x |
- .indent_mods = .indent_mods+ assert_list_of_variables(variables) |
| 151 | +316 |
- )+ |
||
| 152 | -3x | +317 | +1x |
- analyze(+ h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var) |
| 153 | -3x | +|||
| 318 | +
- lyt,+ } |
|||
| 154 | -3x | +|||
| 319 | +
- vars,+ |
|||
| 155 | -3x | +|||
| 320 | +
- afun = afun,+ #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun` |
|||
| 156 | -3x | +|||
| 321 | +
- na_str = na_str,+ #' in `count_abnormal_lab_worsen_by_baseline()`. |
|||
| 157 | -3x | +|||
| 322 | +
- nested = nested,+ #' |
|||
| 158 | -3x | +|||
| 323 | +
- extra_args = extra_args,+ #' @return |
|||
| 159 | -3x | +|||
| 324 | +
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with |
|||
| 160 | -3x | +|||
| 325 | +
- table_names = table_names+ #' formatted [rtables::CellValue()]. |
|||
| 161 | +326 |
- )+ #' |
||
| 162 | +327 |
- }+ #' @keywords internal |
| 1 | +328 |
- #' Get default statistical methods and their associated formats, labels, and indent modifiers+ a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint |
||
| 2 | +329 |
- #'+ s_count_abnormal_lab_worsen_by_baseline, |
||
| 3 | +330 |
- #' @description `r lifecycle::badge("stable")`
+ .formats = c(fraction = format_fraction), |
||
| 4 | +331 |
- #'+ .ungroup_stats = "fraction" |
||
| 5 | +332 |
- #' Utility functions to get valid statistic methods for different method groups+ ) |
||
| 6 | +333 |
- #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers+ |
||
| 7 | +334 |
- #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be+ #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function |
||
| 8 | +335 |
- #' seen in [analyze_vars()]. See notes to understand why this is experimental.+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 9 | +336 |
#' |
||
| 10 | +337 |
- #' @param stats (`character`)\cr statistical methods to get defaults for.+ #' @return |
||
| 11 | +338 |
- #'+ #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting |
||
| 12 | +339 |
- #' @details+ #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted |
||
| 13 | +340 |
- #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`.+ #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout. |
||
| 14 | +341 |
#' |
||
| 15 | +342 |
- #' @note+ #' @examples |
||
| 16 | +343 |
- #' These defaults are experimental because we use the names of functions to retrieve the default+ #' library(dplyr) |
||
| 17 | +344 |
- #' statistics. This should be generalized in groups of methods according to more reasonable groupings.+ #' |
||
| 18 | +345 |
- #'+ #' # The direction variable, GRADDR, is based on metadata |
||
| 19 | +346 |
- #' @name default_stats_formats_labels+ #' adlb <- tern_ex_adlb %>% |
||
| 20 | +347 |
- NULL+ #' mutate( |
||
| 21 | +348 |
-
+ #' GRADDR = case_when( |
||
| 22 | +349 |
- #' @describeIn default_stats_formats_labels Get statistics available for a given method+ #' PARAMCD == "ALT" ~ "B", |
||
| 23 | +350 |
- #' group (analyze function). To check available defaults see `tern::tern_default_stats` list.+ #' PARAMCD == "CRP" ~ "L", |
||
| 24 | +351 |
- #'+ #' PARAMCD == "IGA" ~ "H" |
||
| 25 | +352 |
- #' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function)+ #' ) |
||
| 26 | +353 |
- #' to retrieve default statistics for. A character vector can be used to specify more than one statistical+ #' ) %>% |
||
| 27 | +354 |
- #' method group.+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 28 | +355 |
- #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group.+ #' |
||
| 29 | +356 |
- #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains+ #' df <- h_adlb_worsen( |
||
| 30 | +357 |
- #' `"analyze_vars_counts"`) be added to the statistical methods?+ #' adlb, |
||
| 31 | +358 |
- #'+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 32 | +359 |
- #' @return+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 33 | +360 |
- #' * `get_stats()` returns a `character` vector of statistical methods.+ #' direction_var = "GRADDR" |
||
| 34 | +361 | ++ |
+ #' )+ |
+ |
| 362 |
#' |
|||
| 35 | +363 |
- #' @examples+ #' basic_table() %>% |
||
| 36 | +364 |
- #' # analyze_vars is numeric+ #' split_cols_by("ARMCD") %>%
|
||
| 37 | +365 |
- #' num_stats <- get_stats("analyze_vars_numeric") # also the default
+ #' add_colcounts() %>% |
||
| 38 | +366 |
- #'+ #' split_rows_by("PARAMCD") %>%
|
||
| 39 | +367 |
- #' # Other type+ #' split_rows_by("GRADDR") %>%
|
||
| 40 | +368 |
- #' cnt_stats <- get_stats("analyze_vars_counts")
+ #' count_abnormal_lab_worsen_by_baseline( |
||
| 41 | +369 |
- #'+ #' var = "ATOXGR", |
||
| 42 | +370 |
- #' # Weirdly taking the pval from count_occurrences+ #' variables = list( |
||
| 43 | +371 |
- #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
+ #' id = "USUBJID", |
||
| 44 | +372 |
- #'+ #' baseline_var = "BTOXGR", |
||
| 45 | +373 |
- #' # All count_occurrences+ #' direction_var = "GRADDR" |
||
| 46 | +374 |
- #' all_cnt_occ <- get_stats("count_occurrences")
+ #' ) |
||
| 47 | +375 |
- #'+ #' ) %>% |
||
| 48 | +376 |
- #' # Multiple+ #' append_topleft("Direction of Abnormality") %>%
|
||
| 49 | +377 |
- #' get_stats(c("count_occurrences", "analyze_vars_counts"))
+ #' build_table(df = df, alt_counts_df = tern_ex_adsl) |
||
| 50 | +378 |
#' |
||
| 51 | +379 |
#' @export |
||
| 52 | +380 |
- get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
+ #' @order 2 |
||
| 53 | -612x | +|||
| 381 | +
- checkmate::assert_character(method_groups)+ count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint |
|||
| 54 | -612x | +|||
| 382 | +
- checkmate::assert_character(stats_in, null.ok = TRUE)+ var, |
|||
| 55 | -612x | +|||
| 383 | +
- checkmate::assert_flag(add_pval)+ variables = list( |
|||
| 56 | +384 |
-
+ id = "USUBJID", |
||
| 57 | +385 |
- # Default is still numeric- |
- ||
| 58 | -612x | -
- if (any(method_groups == "analyze_vars")) {
- |
- ||
| 59 | -3x | -
- method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"+ baseline_var = "BTOXGR", |
||
| 60 | +386 |
- }+ direction_var = "GRADDR" |
||
| 61 | +387 |
-
+ ), |
||
| 62 | -612x | +|||
| 388 | +
- type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
+ na_str = default_na_str(), |
|||
| 63 | +389 |
-
+ nested = TRUE, |
||
| 64 | +390 |
- # Defaults for loop+ ..., |
||
| 65 | -612x | +|||
| 391 | +
- out <- NULL+ table_names = NULL, |
|||
| 66 | +392 |
-
+ .stats = NULL, |
||
| 67 | +393 |
- # Loop for multiple method groups+ .formats = NULL, |
||
| 68 | -612x | +|||
| 394 | +
- for (mgi in method_groups) {
+ .labels = NULL, |
|||
| 69 | -639x | +|||
| 395 | +
- out_tmp <- if (mgi %in% names(tern_default_stats)) {
+ .indent_mods = NULL) {
|
|||
| 70 | -638x | +396 | +1x |
- tern_default_stats[[mgi]]+ checkmate::assert_string(var) |
| 71 | +397 |
- } else {
+
|
||
| 72 | +398 | 1x |
- stop("The selected method group (", mgi, ") has no default statistical method.")
+ extra_args <- list(variables = variables, ...) |
|
| 73 | +399 |
- }+ |
||
| 74 | -638x | +400 | +1x |
- out <- unique(c(out, out_tmp))+ afun <- make_afun( |
| 75 | -+ | |||
| 401 | +1x |
- }+ a_count_abnormal_lab_worsen_by_baseline, |
||
| 76 | -+ | |||
| 402 | +1x |
-
+ .stats = .stats, |
||
| 77 | -+ | |||
| 403 | +1x |
- # If you added pval to the stats_in you certainly want it+ .formats = .formats, |
||
| 78 | -611x | +404 | +1x |
- if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
+ .labels = .labels, |
| 79 | -22x | +405 | +1x |
- stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
+ .indent_mods = .indent_mods |
| 80 | +406 |
-
+ ) |
||
| 81 | +407 |
- # Must be only one value between choices+ |
||
| 82 | -22x | -
- checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
- |
- ||
| 83 | -+ | 408 | +1x |
-
+ lyt <- analyze( |
| 84 | -+ | |||
| 409 | +1x |
- # Mismatch with counts and numeric+ lyt = lyt, |
||
| 85 | -21x | +410 | +1x |
- if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
+ vars = var, |
| 86 | -21x | +411 | +1x |
- any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
+ afun = afun, |
| 87 | -2x | +412 | +1x |
- stop(+ na_str = na_str, |
| 88 | -2x | +413 | +1x |
- "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
+ nested = nested, |
| 89 | -2x | +414 | +1x |
- type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),+ extra_args = extra_args, |
| 90 | -2x | +415 | +1x |
- " instead."+ show_labels = "hidden" |
| 91 | +416 |
- )+ ) |
||
| 92 | +417 |
- }+ |
||
| 93 | -+ | |||
| 418 | +1x |
-
+ lyt |
||
| 94 | +419 |
- # Lets add it even if present (thanks to unique)+ } |
||
| 95 | -19x | +
| 1 | +
- add_pval <- TRUE+ #' Create a forest plot from an `rtable` |
|||
| 96 | +2 |
- }+ #' |
||
| 97 | +3 |
-
+ #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2 |
||
| 98 | +4 |
- # Mainly used in "analyze_vars" but it could be necessary elsewhere+ #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The |
||
| 99 | -608x | +|||
| 5 | +
- if (isTRUE(add_pval)) {
+ #' table and forest plot are printed side-by-side. |
|||
| 100 | -29x | +|||
| 6 | +
- if (any(grepl("counts", method_groups))) {
+ #' |
|||
| 101 | -16x | +|||
| 7 | +
- out <- unique(c(out, "pval_counts"))+ #' @description `r lifecycle::badge("stable")`
|
|||
| 102 | +8 |
- } else {
+ #' |
||
| 103 | -13x | +|||
| 9 | +
- out <- unique(c(out, "pval"))+ #' @inheritParams rtable2gg |
|||
| 104 | +10 |
- }+ #' @inheritParams argument_convention |
||
| 105 | +11 |
- }+ #' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2 |
||
| 106 | +12 |
-
+ #' values. |
||
| 107 | +13 |
- # Filtering for stats_in (character vector)+ #' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from |
||
| 108 | -608x | +|||
| 14 | +
- if (!is.null(stats_in)) {
+ #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded |
|||
| 109 | -556x | +|||
| 15 | +
- out <- intersect(stats_in, out) # It orders them too+ #' from forest plot. |
|||
| 110 | +16 |
- }+ #' @param col_ci (`integer(1)` or `NULL`)\cr column index with confidence intervals. By default tries to get this from |
||
| 111 | +17 |
-
+ #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded |
||
| 112 | +18 |
- # If intersect did not find matches (and no pval?) -> error+ #' from forest plot. |
||
| 113 | -608x | +|||
| 19 | +
- if (length(out) == 0) {
+ #' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. |
|||
| 114 | -2x | +|||
| 20 | +
- stop(+ #' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively. |
|||
| 115 | -2x | +|||
| 21 | +
- "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
+ #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute |
|||
| 116 | -2x | +|||
| 22 | +
- " do not have the required default statistical methods:\n",+ #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to |
|||
| 117 | -2x | +|||
| 23 | +
- paste0(stats_in, collapse = " ")+ #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not. |
|||
| 118 | +24 |
- )+ #' @param xlim (`numeric(2)`)\cr limits for x axis. |
||
| 119 | +25 |
- }+ #' @param logx (`flag`)\cr show the x-values on logarithm scale. |
||
| 120 | +26 |
-
+ #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values. |
||
| 121 | -606x | +|||
| 27 | +
- out+ #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
|
|||
| 122 | +28 |
- }+ #' @param width_columns (`numeric`)\cr a vector of column widths. Each element's position in |
||
| 123 | +29 |
-
+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated |
||
| 124 | +30 |
- #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics.+ #' according to maximum number of characters per column. |
||
| 125 | +31 |
- #' To check available defaults see `tern::tern_default_formats` list.+ #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
|
||
| 126 | +32 |
- #'+ #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative |
||
| 127 | +33 |
- #' @param formats_in (named `vector`)\cr inserted formats to replace defaults. It can be a+ #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored. |
||
| 128 | +34 |
- #' character vector from [formatters::list_valid_format_labels()] or a custom format function.+ #' @param font_size (`numeric(1)`)\cr font size. |
||
| 129 | +35 |
- #'+ #' @param col_symbol_size (`numeric` or `NULL`)\cr column index from `tbl` containing data to be used |
||
| 130 | +36 |
- #' @return+ #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional |
||
| 131 | +37 |
- #' * `get_formats_from_stats()` returns a named vector of formats (if present in either+ #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. |
||
| 132 | +38 |
- #' `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from+ #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. |
||
| 133 | +39 |
- #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]).+ #' @param col (`character`)\cr color(s). |
||
| 134 | +40 |
- #'+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
||
| 135 | +41 |
- #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list |
||
| 136 | +42 |
- #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
+ #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are |
||
| 137 | +43 |
- #'+ #' printed side-by-side via [cowplot::plot_grid()]. |
||
| 138 | +44 |
- #' @examples+ #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 139 | +45 |
- #' # Defaults formats+ #' is no longer used. |
||
| 140 | +46 |
- #' get_formats_from_stats(num_stats)+ #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 141 | +47 |
- #' get_formats_from_stats(cnt_stats)+ #' is no longer used. |
||
| 142 | +48 |
- #' get_formats_from_stats(only_pval)+ #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 143 | +49 |
- #' get_formats_from_stats(all_cnt_occ)+ #' is no longer used. |
||
| 144 | +50 |
#' |
||
| 145 | +51 |
- #' # Addition of customs+ #' @return `ggplot` forest plot and table. |
||
| 146 | +52 |
- #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
+ #' |
||
| 147 | +53 |
- #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
+ #' @examples |
||
| 148 | +54 |
- #'+ #' library(dplyr) |
||
| 149 | +55 |
- #' @seealso [formatting_functions]+ #' library(forcats) |
||
| 150 | +56 |
#' |
||
| 151 | +57 |
- #' @export+ #' adrs <- tern_ex_adrs |
||
| 152 | +58 |
- get_formats_from_stats <- function(stats, formats_in = NULL) {
- |
- ||
| 153 | -599x | -
- checkmate::assert_character(stats, min.len = 1)+ #' n_records <- 20 |
||
| 154 | +59 |
- # It may be a list if there is a function in the formats+ #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) |
||
| 155 | -599x | +|||
| 60 | +
- if (checkmate::test_list(formats_in, null.ok = TRUE)) {
+ #' adrs <- adrs %>% |
|||
| 156 | -522x | +|||
| 61 | +
- checkmate::assert_list(formats_in, null.ok = TRUE)+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 157 | +62 |
- # Or it may be a vector of characters+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 158 | +63 |
- } else {
+ #' slice(seq_len(n_records)) %>% |
||
| 159 | -77x | +|||
| 64 | +
- checkmate::assert_character(formats_in, null.ok = TRUE)+ #' droplevels() %>% |
|||
| 160 | +65 |
- }+ #' mutate( |
||
| 161 | +66 |
-
+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 162 | +67 |
- # Extract global defaults+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 163 | -599x | +|||
| 68 | +
- which_fmt <- match(stats, names(tern_default_formats))+ #' rsp = AVALC == "CR" |
|||
| 164 | +69 |
-
+ #' ) |
||
| 165 | +70 |
- # Select only needed formats from stats+ #' formatters::var_labels(adrs) <- c(adrs_labels, "Response") |
||
| 166 | -599x | +|||
| 71 | +
- ret <- vector("list", length = length(stats)) # Returning a list is simpler
+ #' df <- extract_rsp_subgroups( |
|||
| 167 | -599x | +|||
| 72 | +
- ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]]+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
|
|||
| 168 | +73 |
-
+ #' data = adrs |
||
| 169 | -599x | +|||
| 74 | +
- out <- setNames(ret, stats)+ #' ) |
|||
| 170 | +75 |
-
+ #' # Full commonly used response table. |
||
| 171 | +76 |
- # Modify some with custom formats+ #' |
||
| 172 | -599x | +|||
| 77 | +
- if (!is.null(formats_in)) {
+ #' tbl <- basic_table() %>% |
|||
| 173 | +78 |
- # Stats is the main+ #' tabulate_rsp_subgroups(df) |
||
| 174 | -165x | +|||
| 79 | +
- common_names <- intersect(names(out), names(formats_in))+ #' g_forest(tbl) |
|||
| 175 | -165x | +|||
| 80 | +
- out[common_names] <- formats_in[common_names]+ #' |
|||
| 176 | +81 |
- }+ #' # Odds ratio only table. |
||
| 177 | +82 |
-
+ #' |
||
| 178 | -599x | +|||
| 83 | +
- out+ #' tbl_or <- basic_table() %>% |
|||
| 179 | +84 |
- }+ #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
|
||
| 180 | +85 |
-
+ #' g_forest( |
||
| 181 | +86 |
- #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics.+ #' tbl_or, |
||
| 182 | +87 |
- #' To check for available defaults see `tern::tern_default_labels` list. If not available there,+ #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
|
||
| 183 | +88 |
- #' the statistics name will be used as label.+ #' ) |
||
| 184 | +89 |
#' |
||
| 185 | +90 |
- #' @param labels_in (named `character`)\cr inserted labels to replace defaults.+ #' # Survival forest plot example. |
||
| 186 | +91 |
- #' @param row_nms (`character`)\cr row names. Levels of a `factor` or `character` variable, each+ #' adtte <- tern_ex_adtte |
||
| 187 | +92 |
- #' of which the statistics in `.stats` will be calculated for. If this parameter is set, these+ #' # Save variable labels before data processing steps. |
||
| 188 | +93 |
- #' variable levels will be used as the defaults, and the names of the given custom values should+ #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) |
||
| 189 | +94 |
- #' correspond to levels (or have format `statistic.level`) instead of statistics. Can also be+ #' adtte_f <- adtte %>% |
||
| 190 | +95 |
- #' variable names if rows correspond to different variables instead of levels. Defaults to `NULL`.+ #' filter( |
||
| 191 | +96 |
- #'+ #' PARAMCD == "OS", |
||
| 192 | +97 |
- #' @return+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 193 | +98 |
- #' * `get_labels_from_stats()` returns a named `character` vector of labels (if present in either+ #' SEX %in% c("M", "F")
|
||
| 194 | +99 |
- #' `tern_default_labels` or `labels_in`, otherwise `NULL`).+ #' ) %>% |
||
| 195 | +100 |
- #'+ #' mutate( |
||
| 196 | +101 |
- #' @examples+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 197 | +102 |
- #' # Defaults labels+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 198 | +103 |
- #' get_labels_from_stats(num_stats)+ #' SEX = droplevels(SEX), |
||
| 199 | +104 |
- #' get_labels_from_stats(cnt_stats)+ #' AVALU = as.character(AVALU), |
||
| 200 | +105 |
- #' get_labels_from_stats(only_pval)+ #' is_event = CNSR == 0 |
||
| 201 | +106 |
- #' get_labels_from_stats(all_cnt_occ)+ #' ) |
||
| 202 | +107 |
- #'+ #' labels <- list( |
||
| 203 | +108 |
- #' # Addition of customs+ #' "ARM" = adtte_labels["ARM"], |
||
| 204 | +109 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
+ #' "SEX" = adtte_labels["SEX"], |
||
| 205 | +110 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
+ #' "AVALU" = adtte_labels["AVALU"], |
||
| 206 | +111 |
- #'+ #' "is_event" = "Event Flag" |
||
| 207 | +112 |
- #' @export+ #' ) |
||
| 208 | +113 |
- get_labels_from_stats <- function(stats, labels_in = NULL, row_nms = NULL) {
- |
- ||
| 209 | -588x | -
- checkmate::assert_character(stats, min.len = 1)+ #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) |
||
| 210 | -588x | +|||
| 114 | +
- checkmate::assert_character(row_nms, null.ok = TRUE)+ #' df <- extract_survival_subgroups( |
|||
| 211 | +115 |
- # It may be a list+ #' variables = list( |
||
| 212 | -588x | +|||
| 116 | +
- if (checkmate::test_list(labels_in, null.ok = TRUE)) {
+ #' tte = "AVAL", |
|||
| 213 | -483x | +|||
| 117 | +
- checkmate::assert_list(labels_in, null.ok = TRUE)+ #' is_event = "is_event", |
|||
| 214 | +118 |
- # Or it may be a vector of characters+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 215 | +119 |
- } else {
+ #' ), |
||
| 216 | -105x | +|||
| 120 | +
- checkmate::assert_character(labels_in, null.ok = TRUE)+ #' data = adtte_f |
|||
| 217 | +121 |
- }+ #' ) |
||
| 218 | +122 |
-
+ #' table_hr <- basic_table() %>% |
||
| 219 | -588x | +|||
| 123 | +
- if (!is.null(row_nms)) {
+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
|||
| 220 | -168x | +|||
| 124 | +
- ret <- rep(row_nms, length(stats))+ #' g_forest(table_hr) |
|||
| 221 | -168x | +|||
| 125 | +
- out <- setNames(ret, paste(rep(stats, each = length(row_nms)), ret, sep = "."))+ #' |
|||
| 222 | +126 |
-
+ #' # Works with any `rtable`. |
||
| 223 | -168x | +|||
| 127 | +
- if (!is.null(labels_in)) {
+ #' tbl <- rtable( |
|||
| 224 | -4x | +|||
| 128 | +
- lvl_lbls <- intersect(names(labels_in), row_nms)+ #' header = c("E", "CI", "N"),
|
|||
| 225 | -4x | +|||
| 129 | +
- for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- labels_in[[i]]+ #' rrow("", 1, c(.8, 1.2), 200),
|
|||
| 226 | +130 |
- }+ #' rrow("", 1.2, c(1.1, 1.4), 50)
|
||
| 227 | +131 |
- } else {
+ #' ) |
||
| 228 | -420x | +|||
| 132 | +
- which_lbl <- match(stats, names(tern_default_labels))+ #' g_forest( |
|||
| 229 | +133 |
-
+ #' tbl = tbl, |
||
| 230 | -420x | +|||
| 134 | +
- ret <- stats # The default+ #' col_x = 1, |
|||
| 231 | -420x | +|||
| 135 | +
- ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]]+ #' col_ci = 2, |
|||
| 232 | +136 |
-
+ #' xlim = c(0.5, 2), |
||
| 233 | -420x | +|||
| 137 | +
- out <- setNames(ret, stats)+ #' x_at = c(0.5, 1, 2), |
|||
| 234 | +138 |
- }+ #' col_symbol_size = 3 |
||
| 235 | +139 |
-
+ #' ) |
||
| 236 | +140 |
- # Modify some with custom labels+ #' |
||
| 237 | -588x | +|||
| 141 | +
- if (!is.null(labels_in)) {
+ #' tbl <- rtable( |
|||
| 238 | +142 |
- # Stats is the main+ #' header = rheader( |
||
| 239 | -110x | +|||
| 143 | +
- common_names <- intersect(names(out), names(labels_in))+ #' rrow("", rcell("A", colspan = 2)),
|
|||
| 240 | -110x | +|||
| 144 | +
- out[common_names] <- labels_in[common_names]+ #' rrow("", "c1", "c2")
|
|||
| 241 | +145 |
- }+ #' ), |
||
| 242 | +146 |
-
+ #' rrow("row 1", 1, c(.8, 1.2)),
|
||
| 243 | -588x | +|||
| 147 | +
- out+ #' rrow("row 2", 1.2, c(1.1, 1.4))
|
|||
| 244 | +148 |
- }+ #' ) |
||
| 245 | +149 |
-
+ #' g_forest( |
||
| 246 | +150 |
- #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics.+ #' tbl = tbl, |
||
| 247 | +151 |
- #' It defaults to 0L for all values.+ #' col_x = 1, |
||
| 248 | +152 |
- #'+ #' col_ci = 2, |
||
| 249 | +153 |
- #' @param indents_in (named `vector`)\cr inserted indent modifiers to replace defaults (default is `0L`).+ #' xlim = c(0.5, 2), |
||
| 250 | +154 |
- #'+ #' x_at = c(0.5, 1, 2), |
||
| 251 | +155 |
- #' @return+ #' vline = 1, |
||
| 252 | +156 |
- #' * `get_indents_from_stats()` returns a single indent modifier value to apply to all rows+ #' forest_header = c("Hello", "World")
|
||
| 253 | +157 |
- #' or a named numeric vector of indent modifiers (if present, otherwise `NULL`).+ #' ) |
||
| 254 | +158 |
#' |
||
| 255 | +159 |
- #' @examples+ #' @export |
||
| 256 | +160 |
- #' get_indents_from_stats(all_cnt_occ, indents_in = 3L)+ g_forest <- function(tbl, |
||
| 257 | +161 |
- #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L))+ col_x = attr(tbl, "col_x"), |
||
| 258 | +162 |
- #' get_indents_from_stats(+ col_ci = attr(tbl, "col_ci"), |
||
| 259 | +163 |
- #' all_cnt_occ,+ vline = 1, |
||
| 260 | +164 |
- #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L), row_nms = c("a", "b")
+ forest_header = attr(tbl, "forest_header"), |
||
| 261 | +165 |
- #' )+ xlim = c(0.1, 10), |
||
| 262 | +166 |
- #'+ logx = TRUE, |
||
| 263 | +167 |
- #' @export+ x_at = c(0.1, 1, 10), |
||
| 264 | +168 |
- get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
- |
- ||
| 265 | -548x | -
- checkmate::assert_character(stats, min.len = 1)+ width_row_names = lifecycle::deprecated(), |
||
| 266 | -548x | +|||
| 169 | +
- checkmate::assert_character(row_nms, null.ok = TRUE)+ width_columns = NULL, |
|||
| 267 | +170 |
- # It may be a list+ width_forest = lifecycle::deprecated(), |
||
| 268 | -548x | +|||
| 171 | +
- if (checkmate::test_list(indents_in, null.ok = TRUE)) {
+ lbl_col_padding = 0, |
|||
| 269 | -497x | +|||
| 172 | +
- checkmate::assert_list(indents_in, null.ok = TRUE)+ rel_width_forest = 0.25, |
|||
| 270 | +173 |
- # Or it may be a vector of integers+ font_size = 12, |
||
| 271 | +174 |
- } else {
+ col_symbol_size = attr(tbl, "col_symbol_size"), |
||
| 272 | -51x | +|||
| 175 | +
- checkmate::assert_integerish(indents_in, null.ok = TRUE)+ col = getOption("ggplot2.discrete.colour")[1],
|
|||
| 273 | +176 |
- }+ ggtheme = NULL, |
||
| 274 | +177 |
-
+ as_list = FALSE, |
||
| 275 | -548x | +|||
| 178 | +
- if (is.null(names(indents_in)) && length(indents_in) == 1) {
+ gp = lifecycle::deprecated(), |
|||
| 276 | -18x | +|||
| 179 | +
- out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1)+ draw = lifecycle::deprecated(), |
|||
| 277 | -18x | +|||
| 180 | +
- return(out)+ newpage = lifecycle::deprecated()) {
|
|||
| 278 | +181 |
- }+ # Deprecated argument warnings |
||
| 279 | -+ | |||
| 182 | +4x |
-
+ if (lifecycle::is_present(width_row_names)) {
|
||
| 280 | -530x | +183 | +1x |
- if (!is.null(row_nms)) {
+ lifecycle::deprecate_warn( |
| 281 | -153x | +184 | +1x |
- ret <- rep(0L, length(stats) * length(row_nms))+ "0.9.4", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", |
| 282 | -153x | +185 | +1x |
- out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = "."))+ details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." |
| 283 | +186 |
-
+ ) |
||
| 284 | -153x | +|||
| 187 | +
- if (!is.null(indents_in)) {
+ } |
|||
| 285 | +188 | 4x |
- lvl_lbls <- intersect(names(indents_in), row_nms)+ if (lifecycle::is_present(width_forest)) {
|
|
| 286 | -4x | +189 | +1x |
- for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]]+ lifecycle::deprecate_warn(+ |
+
| 190 | +1x | +
+ "0.9.4", "g_forest(width_forest)", "g_forest(rel_width_forest)",+ |
+ ||
| 191 | +1x | +
+ details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." |
||
| 287 | +192 |
- }+ ) |
||
| 288 | +193 |
- } else {
+ } |
||
| 289 | -377x | +194 | +4x |
- ret <- rep(0L, length(stats))+ if (lifecycle::is_present(gp)) {
|
| 290 | -377x | +195 | +1x |
- out <- setNames(ret, stats)+ lifecycle::deprecate_warn( |
| 291 | -+ | |||
| 196 | +1x |
- }+ "0.9.4", "g_forest(gp)", "g_forest(ggtheme)", |
||
| 292 | -+ | |||
| 197 | +1x |
-
+ details = paste( |
||
| 293 | -+ | |||
| 198 | +1x |
- # Modify some with custom labels+ "`g_forest` is now generated as a `ggplot` object.", |
||
| 294 | -530x | +199 | +1x |
- if (!is.null(indents_in)) {
+ "Additional display settings should be supplied via the `ggtheme` parameter." |
| 295 | +200 |
- # Stats is the main- |
- ||
| 296 | -37x | -
- common_names <- intersect(names(out), names(indents_in))+ ) |
||
| 297 | -37x | +|||
| 201 | +
- out[common_names] <- indents_in[common_names]+ ) |
|||
| 298 | +202 |
} |
||
| 299 | -+ | |||
| 203 | +4x |
-
+ if (lifecycle::is_present(draw)) {
|
||
| 300 | -530x | +204 | +1x |
- out+ lifecycle::deprecate_warn( |
| 301 | -+ | |||
| 205 | +1x |
- }+ "0.9.4", "g_forest(draw)", |
||
| 302 | -+ | |||
| 206 | +1x |
-
+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
||
| 303 | +207 |
- #' Update labels according to control specifications+ ) |
||
| 304 | +208 |
- #'+ } |
||
| 305 | -+ | |||
| 209 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ if (lifecycle::is_present(newpage)) {
|
||
| 306 | -+ | |||
| 210 | +1x |
- #'+ lifecycle::deprecate_warn( |
||
| 307 | -+ | |||
| 211 | +1x |
- #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant+ "0.9.4", "g_forest(newpage)", |
||
| 308 | -+ | |||
| 212 | +1x |
- #' control specification. For example, if control has element `conf_level` set to `0.9`, the default+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
||
| 309 | +213 |
- #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied+ ) |
||
| 310 | +214 |
- #' via `labels_custom` will not be updated regardless of `control`.+ } |
||
| 311 | +215 |
- #'+ |
||
| 312 | -+ | |||
| 216 | +4x |
- #' @param labels_default (named `character`)\cr a named vector of statistic labels to modify+ checkmate::assert_class(tbl, "VTableTree") |
||
| 313 | -+ | |||
| 217 | +4x |
- #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will+ checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
||
| 314 | -+ | |||
| 218 | +4x |
- #' not be affected.+ checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
||
| 315 | -+ | |||
| 219 | +4x |
- #' @param labels_custom (named `character`)\cr named vector of labels that are customized by+ checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
||
| 316 | -+ | |||
| 220 | +4x |
- #' the user and should not be affected by `control`.+ checkmate::assert_number(font_size, lower = 0) |
||
| 317 | -+ | |||
| 221 | +4x |
- #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels.+ checkmate::assert_character(col, null.ok = TRUE) |
||
| 318 | -+ | |||
| 222 | +4x |
- #'+ checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl)) |
||
| 319 | +223 |
- #' @return A named character vector of labels with control specifications applied to relevant labels.+ |
||
| 320 | +224 |
- #'+ # Extract info from table |
||
| 321 | -+ | |||
| 225 | +4x |
- #' @examples+ mat <- matrix_form(tbl, indent_rownames = TRUE) |
||
| 322 | -+ | |||
| 226 | +4x |
- #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57)+ mat_strings <- formatters::mf_strings(mat) |
||
| 323 | -+ | |||
| 227 | +4x |
- #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
+ nlines_hdr <- formatters::mf_nlheader(mat) |
||
| 324 | -+ | |||
| 228 | +4x |
- #' labels_use_control(control = control)+ nrows_body <- nrow(mat_strings) - nlines_hdr |
||
| 325 | -+ | |||
| 229 | +4x |
- #'+ tbl_stats <- mat_strings[nlines_hdr, -1] |
||
| 326 | +230 |
- #' @export+ |
||
| 327 | +231 |
- labels_use_control <- function(labels_default, control, labels_custom = NULL) {
+ # Generate and modify table as ggplot object |
||
| 328 | -20x | +232 | +4x |
- if ("conf_level" %in% names(control)) {
+ gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + |
| 329 | -20x | +233 | +4x |
- labels_default <- sapply(+ theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) |
| 330 | -20x | +234 | +4x |
- names(labels_default),+ gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) |
| 331 | -20x | +235 | +4x |
- function(x) {
+ gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 |
| 332 | -91x | +236 | +4x |
- if (!x %in% names(labels_custom)) {
+ if (nlines_hdr == 2) {
|
| 333 | -88x | -
- gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]]))- |
- ||
| 334 | -+ | 237 | +4x |
- } else {
+ gg_table$scales$scales[[2]]$expand <- c(0, 0) |
| 335 | -3x | +238 | +4x |
- labels_default[[x]]+ arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) |
| 336 | +239 |
- }+ } else {
|
||
| 337 | -+ | |||
| 240 | +! |
- }+ arms <- NULL |
||
| 338 | +241 |
- )+ } |
||
| 339 | +242 |
- }- |
- ||
| 340 | -20x | -
- if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
+
|
||
| 341 | -20x | +243 | +4x |
- !"quantiles" %in% names(labels_custom)) { # nolint
+ tbl_df <- as_result_df(tbl) |
| 342 | -16x | +244 | +4x |
- labels_default["quantiles"] <- gsub(+ dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) |
| 343 | -16x | +245 | +4x |
- "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""),+ tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] |
| 344 | -16x | +246 | +4x |
- labels_default["quantiles"]+ names(tbl_df) <- c("row_num", tbl_stats)
|
| 345 | +247 |
- )+ |
||
| 346 | +248 |
- }+ # Check table data columns |
||
| 347 | -20x | +249 | +4x |
- if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
+ if (!is.null(col_ci)) {
|
| 348 | -20x | +250 | +4x |
- !"mean_pval" %in% names(labels_custom)) { # nolint
+ ci_col <- col_ci + 1 |
| 349 | -2x | +|||
| 251 | +
- labels_default["mean_pval"] <- gsub(+ } else {
|
|||
| 350 | -2x | +|||
| 252 | +! |
- "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"]+ tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) |
||
| 351 | -+ | |||
| 253 | +! |
- )+ ci_col <- which(names(tbl_df) == "empty_ci") |
||
| 352 | +254 |
} |
||
| 255 | +! | +
+ if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
+ |
+ ||
| 353 | +256 | |||
| 354 | -20x | +257 | +4x |
- labels_default+ if (!is.null(col_x)) {
|
| 355 | -+ | |||
| 258 | +4x |
- }+ x_col <- col_x + 1 |
||
| 356 | +259 |
-
+ } else {
|
||
| 357 | -+ | |||
| 260 | +! |
- #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`.+ tbl_df[["empty_x"]] <- NA_real_ |
||
| 358 | -+ | |||
| 261 | +! |
- #'+ x_col <- which(names(tbl_df) == "empty_x") |
||
| 359 | +262 |
- #' @format+ } |
||
| 360 | -+ | |||
| 263 | +4x |
- #' * `tern_default_stats` is a named list of available statistics, with each element+ if (!is.null(col_symbol_size)) {
|
||
| 361 | -+ | |||
| 264 | +3x |
- #' named for their corresponding statistical method group.+ sym_size <- unlist(tbl_df[, col_symbol_size + 1]) |
||
| 362 | +265 |
- #'+ } else {
|
||
| 363 | -+ | |||
| 266 | +1x |
- #' @export+ sym_size <- rep(1, nrow(tbl_df)) |
||
| 364 | +267 |
- tern_default_stats <- list(+ } |
||
| 365 | +268 |
- abnormal = c("fraction"),
+
|
||
| 366 | -+ | |||
| 269 | +4x |
- abnormal_by_baseline = c("fraction"),
+ tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
|
||
| 367 | -+ | |||
| 270 | +4x |
- abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
+ x <- unlist(tbl_df[, x_col]) |
||
| 368 | -+ | |||
| 271 | +4x |
- abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ lwr <- unlist(tbl_df[["ci_lwr"]]) |
||
| 369 | -+ | |||
| 272 | +4x |
- abnormal_by_worst_grade_worsen = c("fraction"),
+ upr <- unlist(tbl_df[["ci_upr"]]) |
||
| 370 | -+ | |||
| 273 | +4x |
- analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
+ row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) |
||
| 371 | +274 |
- analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "fraction", "n_blq"),
+
|
||
| 372 | -+ | |||
| 275 | +! |
- analyze_vars_numeric = c(+ if (is.null(col)) col <- "#343cff" |
||
| 373 | -+ | |||
| 276 | +4x |
- "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval",+ if (length(col) == 1) col <- rep(col, nrow(tbl_df)) |
||
| 374 | -+ | |||
| 277 | +! |
- "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv",+ if (is.null(x_at)) x_at <- union(xlim, vline) |
||
| 375 | -+ | |||
| 278 | +4x |
- "geom_mean", "geom_mean_ci", "geom_cv"+ x_labels <- x_at |
||
| 376 | +279 |
- ),+ |
||
| 377 | +280 |
- count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
+ # Apply log transformation |
||
| 378 | -+ | |||
| 281 | +4x |
- count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
+ if (logx) {
|
||
| 379 | -+ | |||
| 282 | +4x |
- count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
+ x_t <- log(x) |
||
| 380 | -+ | |||
| 283 | +4x |
- count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ lwr_t <- log(lwr) |
||
| 381 | -+ | |||
| 284 | +4x |
- count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ upr_t <- log(upr) |
||
| 382 | -+ | |||
| 285 | +4x |
- count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ xlim_t <- log(xlim) |
||
| 383 | +286 |
- count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ } else {
|
||
| 384 | -+ | |||
| 287 | +! |
- coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
+ x_t <- x |
||
| 385 | -+ | |||
| 288 | +! |
- estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci", "n_unique", "n_rate"),
+ lwr_t <- lwr |
||
| 386 | -+ | |||
| 289 | +! |
- estimate_multinomial_response = c("n_prop", "prop_ci"),
+ upr_t <- upr |
||
| 387 | -+ | |||
| 290 | +! |
- estimate_odds_ratio = c("or_ci", "n_tot"),
+ xlim_t <- xlim |
||
| 388 | +291 |
- estimate_proportion = c("n_prop", "prop_ci"),
+ } |
||
| 389 | +292 |
- estimate_proportion_diff = c("diff", "diff_ci"),
+
|
||
| 390 | +293 |
- summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
+ # Set up plot area |
||
| 391 | -+ | |||
| 294 | +4x |
- summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
+ gg_plt <- ggplot(data = tbl_df) + |
||
| 392 | -+ | |||
| 295 | +4x |
- summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ theme( |
||
| 393 | -+ | |||
| 296 | +4x |
- summarize_num_patients = c("unique", "nonunique", "unique_count"),
+ panel.background = element_rect(fill = "transparent", color = NA_character_), |
||
| 394 | -+ | |||
| 297 | +4x |
- summarize_patients_events_in_cols = c("unique", "all"),
+ plot.background = element_rect(fill = "transparent", color = NA_character_), |
||
| 395 | -+ | |||
| 298 | +4x |
- surv_time = c("median", "median_ci", "quantiles", "range_censor", "range_event", "range"),
+ panel.grid.major = element_blank(), |
||
| 396 | -+ | |||
| 299 | +4x |
- surv_timepoint = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval"),
+ panel.grid.minor = element_blank(), |
||
| 397 | -+ | |||
| 300 | +4x |
- tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ axis.title.x = element_blank(), |
||
| 398 | -+ | |||
| 301 | +4x |
- tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
+ axis.title.y = element_blank(), |
||
| 399 | -+ | |||
| 302 | +4x |
- tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ axis.line.x = element_line(), |
||
| 400 | -+ | |||
| 303 | +4x |
- tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
+ axis.text = element_text(size = font_size), |
||
| 401 | -+ | |||
| 304 | +4x |
- test_proportion_diff = c("pval")
+ legend.position = "none", |
||
| 402 | -+ | |||
| 305 | +4x |
- )+ plot.margin = margin(0, 0.1, 0.05, 0, "npc") |
||
| 403 | +306 |
-
+ ) + |
||
| 404 | -+ | |||
| 307 | +4x |
- #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`.+ scale_x_continuous( |
||
| 405 | -+ | |||
| 308 | +4x |
- #'+ transform = ifelse(logx, "log", "identity"), |
||
| 406 | -+ | |||
| 309 | +4x |
- #' @format+ limits = xlim, |
||
| 407 | -+ | |||
| 310 | +4x |
- #' * `tern_default_formats` is a named vector of available default formats, with each element+ breaks = x_at, |
||
| 408 | -+ | |||
| 311 | +4x |
- #' named for their corresponding statistic.+ labels = x_labels, |
||
| 409 | -+ | |||
| 312 | +4x |
- #'+ expand = c(0.01, 0) |
||
| 410 | +313 |
- #' @export+ ) + |
||
| 411 | -+ | |||
| 314 | +4x |
- tern_default_formats <- c(+ scale_y_continuous( |
||
| 412 | -+ | |||
| 315 | +4x |
- fraction = format_fraction_fixed_dp,+ limits = c(0, nrow(mat_strings) + 1), |
||
| 413 | -+ | |||
| 316 | +4x |
- unique = format_count_fraction_fixed_dp,+ breaks = NULL, |
||
| 414 | -+ | |||
| 317 | +4x |
- nonunique = "xx",+ expand = c(0, 0) |
||
| 415 | +318 |
- unique_count = "xx",+ ) + |
||
| 416 | -+ | |||
| 319 | +4x |
- n = "xx.",+ coord_cartesian(clip = "off") |
||
| 417 | +320 |
- count = "xx.",+ |
||
| 418 | -+ | |||
| 321 | +4x |
- count_fraction = format_count_fraction,+ if (is.null(ggtheme)) {
|
||
| 419 | -+ | |||
| 322 | +4x |
- count_fraction_fixed_dp = format_count_fraction_fixed_dp,+ gg_plt <- gg_plt + annotate( |
||
| 420 | -+ | |||
| 323 | +4x |
- n_blq = "xx.",+ "rect", |
||
| 421 | -+ | |||
| 324 | +4x |
- sum = "xx.x",+ xmin = xlim[1], |
||
| 422 | -+ | |||
| 325 | +4x |
- mean = "xx.x",+ xmax = xlim[2], |
||
| 423 | -+ | |||
| 326 | +4x |
- sd = "xx.x",+ ymin = 0, |
||
| 424 | -+ | |||
| 327 | +4x |
- se = "xx.x",+ ymax = nrows_body + 0.5, |
||
| 425 | -+ | |||
| 328 | +4x |
- mean_sd = "xx.x (xx.x)",+ fill = "grey92" |
||
| 426 | +329 |
- mean_se = "xx.x (xx.x)",+ ) |
||
| 427 | +330 |
- mean_ci = "(xx.xx, xx.xx)",+ } |
||
| 428 | +331 |
- mean_sei = "(xx.xx, xx.xx)",+ |
||
| 429 | -+ | |||
| 332 | +4x |
- mean_sdi = "(xx.xx, xx.xx)",+ if (!is.null(vline)) {
|
||
| 430 | +333 |
- mean_pval = "x.xxxx | (<0.0001)",+ # Set default forest header |
||
| 431 | -+ | |||
| 334 | +4x |
- median = "xx.x",+ if (is.null(forest_header)) {
|
||
| 432 | -+ | |||
| 335 | +! |
- mad = "xx.x",+ forest_header <- c( |
||
| 433 | -+ | |||
| 336 | +! |
- median_ci = "(xx.xx, xx.xx)",+ paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"), |
||
| 434 | -+ | |||
| 337 | +! |
- quantiles = "xx.x - xx.x",+ paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n") |
||
| 435 | +338 |
- iqr = "xx.x",+ ) |
||
| 436 | +339 |
- range = "xx.x - xx.x",+ } |
||
| 437 | +340 |
- min = "xx.x",+ |
||
| 438 | +341 |
- max = "xx.x",+ # Add vline and forest header labels |
||
| 439 | -+ | |||
| 342 | +4x |
- median_range = "xx.x (xx.x - xx.x)",+ mid_pts <- if (logx) {
|
||
| 440 | -+ | |||
| 343 | +4x |
- cv = "xx.x",+ c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2]))))) |
||
| 441 | +344 |
- geom_mean = "xx.x",+ } else {
|
||
| 442 | -+ | |||
| 345 | +! |
- geom_mean_ci = "(xx.xx, xx.xx)",+ c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2]))) |
||
| 443 | +346 |
- geom_cv = "xx.x",+ } |
||
| 444 | -+ | |||
| 347 | +4x |
- pval = "x.xxxx | (<0.0001)",+ gg_plt <- gg_plt + |
||
| 445 | -+ | |||
| 348 | +4x |
- pval_counts = "x.xxxx | (<0.0001)",+ annotate( |
||
| 446 | -+ | |||
| 349 | +4x |
- range_censor = "xx.x to xx.x",+ "segment", |
||
| 447 | -+ | |||
| 350 | +4x |
- range_event = "xx.x to xx.x",+ x = vline, xend = vline, y = 0, yend = nrows_body + 0.5 |
||
| 448 | +351 |
- rate = "xx.xxxx",+ ) + |
||
| 449 | -+ | |||
| 352 | +4x |
- rate_ci = "(xx.xxxx, xx.xxxx)",+ annotate( |
||
| 450 | -+ | |||
| 353 | +4x |
- rate_ratio = "xx.xxxx",+ "text", |
||
| 451 | -+ | |||
| 354 | +4x |
- rate_ratio_ci = "(xx.xxxx, xx.xxxx)"+ x = mid_pts[1], y = nrows_body + 1.25, |
||
| 452 | -+ | |||
| 355 | +4x |
- )+ label = forest_header[1], |
||
| 453 | -+ | |||
| 356 | +4x |
-
+ size = font_size / .pt, |
||
| 454 | -+ | |||
| 357 | +4x |
- #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`.+ lineheight = 0.9 |
||
| 455 | +358 |
- #'+ ) + |
||
| 456 | -+ | |||
| 359 | +4x |
- #' @format+ annotate( |
||
| 457 | -+ | |||
| 360 | +4x |
- #' * `tern_default_labels` is a named `character` vector of available default labels, with each element+ "text", |
||
| 458 | -+ | |||
| 361 | +4x |
- #' named for their corresponding statistic.+ x = mid_pts[2], y = nrows_body + 1.25, |
||
| 459 | -+ | |||
| 362 | +4x |
- #'+ label = forest_header[2], |
||
| 460 | -+ | |||
| 363 | +4x |
- #' @export+ size = font_size / .pt, |
||
| 461 | -+ | |||
| 364 | +4x |
- tern_default_labels <- c(+ lineheight = 0.9 |
||
| 462 | +365 |
- fraction = "fraction",+ ) |
||
| 463 | +366 |
- unique = "Number of patients with at least one event",+ } |
||
| 464 | +367 |
- nonunique = "Number of events",+ |
||
| 465 | +368 |
- n = "n",+ # Add points to plot |
||
| 466 | -+ | |||
| 369 | +4x |
- count = "count",+ if (any(!is.na(x_t))) {
|
||
| 467 | -+ | |||
| 370 | +4x |
- count_fraction = "count_fraction",+ x_t[x < xlim[1] | x > xlim[2]] <- NA |
||
| 468 | -+ | |||
| 371 | +4x |
- count_fraction_fixed_dp = "count_fraction",+ gg_plt <- gg_plt + geom_point( |
||
| 469 | -+ | |||
| 372 | +4x |
- n_blq = "n_blq",+ x = x_t, |
||
| 470 | -+ | |||
| 373 | +4x |
- sum = "Sum",+ y = row_num, |
||
| 471 | -+ | |||
| 374 | +4x |
- mean = "Mean",+ color = col, |
||
| 472 | -+ | |||
| 375 | +4x |
- sd = "SD",+ aes(size = sym_size), |
||
| 473 | -+ | |||
| 376 | +4x |
- se = "SE",+ na.rm = TRUE |
||
| 474 | +377 |
- mean_sd = "Mean (SD)",+ ) |
||
| 475 | +378 |
- mean_se = "Mean (SE)",+ } |
||
| 476 | +379 |
- mean_ci = "Mean 95% CI",+ |
||
| 477 | -+ | |||
| 380 | +4x |
- mean_sei = "Mean -/+ 1xSE",+ for (i in seq_len(nrow(tbl_df))) {
|
||
| 478 | +381 |
- mean_sdi = "Mean -/+ 1xSD",+ # Determine which arrow(s) to add to CI lines |
||
| 479 | -+ | |||
| 382 | +17x |
- mean_pval = "Mean p-value (H0: mean = 0)",+ which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) |
||
| 480 | -+ | |||
| 383 | +17x |
- median = "Median",+ which_arrow <- dplyr::case_when( |
||
| 481 | -+ | |||
| 384 | +17x |
- mad = "Median Absolute Deviation",+ all(which_arrow) ~ "both", |
||
| 482 | -+ | |||
| 385 | +17x |
- median_ci = "Median 95% CI",+ which_arrow[1] ~ "first", |
||
| 483 | -+ | |||
| 386 | +17x |
- quantiles = "25% and 75%-ile",+ which_arrow[2] ~ "last", |
||
| 484 | -+ | |||
| 387 | +17x |
- iqr = "IQR",+ TRUE ~ NA_character_ |
||
| 485 | +388 |
- range = "Min - Max",+ ) |
||
| 486 | +389 |
- min = "Minimum",+ |
||
| 487 | +390 |
- max = "Maximum",+ # Add CI lines |
||
| 488 | -+ | |||
| 391 | +17x |
- median_range = "Median (Min - Max)",+ gg_plt <- gg_plt + |
||
| 489 | -+ | |||
| 392 | +17x |
- cv = "CV (%)",+ if (!is.na(which_arrow)) {
|
||
| 490 | -+ | |||
| 393 | +15x |
- geom_mean = "Geometric Mean",+ annotate( |
||
| 491 | -+ | |||
| 394 | +15x |
- geom_mean_ci = "Geometric Mean 95% CI",+ "segment", |
||
| 492 | -+ | |||
| 395 | +15x |
- geom_cv = "CV % Geometric Mean",+ x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
|
||
| 493 | -+ | |||
| 396 | +15x |
- pval = "p-value (t-test)", # Default for numeric+ xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
|
||
| 494 | -+ | |||
| 397 | +15x |
- pval_counts = "p-value (chi-squared test)", # Default for counts+ y = row_num[i], yend = row_num[i], |
||
| 495 | -+ | |||
| 398 | +15x |
- rate = "Adjusted Rate",+ color = if (length(col) == 1) col else col[i], |
||
| 496 | -+ | |||
| 399 | +15x |
- rate_ratio = "Adjusted Rate Ratio"+ arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow), |
||
| 497 | -+ | |||
| 400 | +15x |
- )+ na.rm = TRUE |
||
| 498 | +401 |
-
+ ) |
||
| 499 | +402 |
- # To deprecate ---------+ } else {
|
||
| 500 | -+ | |||
| 403 | +2x |
-
+ annotate( |
||
| 501 | -+ | |||
| 404 | +2x |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
+ "segment", |
||
| 502 | -+ | |||
| 405 | +2x |
- #' Quick function to retrieve default formats for summary statistics:+ x = lwr[i], xend = upr[i], |
||
| 503 | -+ | |||
| 406 | +2x |
- #' [analyze_vars()] and [analyze_vars_in_cols()] principally.+ y = row_num[i], yend = row_num[i], |
||
| 504 | -+ | |||
| 407 | +2x |
- #'+ color = if (length(col) == 1) col else col[i], |
||
| 505 | -+ | |||
| 408 | +2x |
- #' @param type (`string`)\cr `"numeric"` or `"counts"`.+ na.rm = TRUE |
||
| 506 | +409 |
- #'+ ) |
||
| 507 | +410 |
- #' @return+ } |
||
| 508 | +411 |
- #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type.+ } |
||
| 509 | +412 |
- #'+ |
||
| 510 | +413 |
- #' @examples+ # Apply custom ggtheme to plot |
||
| 511 | -+ | |||
| 414 | +! |
- #' summary_formats()+ if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
||
| 512 | +415 |
- #' summary_formats(type = "counts", include_pval = TRUE)+ |
||
| 513 | -+ | |||
| 416 | +4x |
- #'+ if (as_list) {
+ |
+ ||
| 417 | +1x | +
+ list(+ |
+ ||
| 418 | +1x | +
+ table = gg_table,+ |
+ ||
| 419 | +1x | +
+ plot = gg_plt |
||
| 514 | +420 |
- #' @export+ ) |
||
| 515 | +421 |
- summary_formats <- function(type = "numeric", include_pval = FALSE) {
+ } else {
|
||
| 516 | -2x | +422 | +3x |
- lifecycle::deprecate_warn(+ cowplot::plot_grid( |
| 517 | -2x | +423 | +3x |
- "0.9.6", "summary_formats()",+ gg_table, |
| 518 | -2x | +424 | +3x |
- details = 'Use get_formats_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
+ gg_plt, |
| 519 | -+ | |||
| 425 | +3x |
- )+ align = "h", |
||
| 520 | -2x | +426 | +3x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ axis = "tblr", |
| 521 | -2x | +427 | +3x |
- get_formats_from_stats(get_stats(met_grp, add_pval = include_pval))+ rel_widths = c(1 - rel_width_forest, rel_width_forest) |
| 522 | +428 |
- }+ ) |
||
| 523 | +429 |
-
+ } |
||
| 524 | +430 |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
+ } |
||
| 525 | +431 |
- #' Quick function to retrieve default labels for summary statistics.+ |
||
| 526 | +432 |
- #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`.+ #' Forest plot grob |
||
| 527 | +433 |
#' |
||
| 528 | +434 |
- #' @param include_pval (`flag`)\cr same as the `add_pval` argument in [get_stats()].+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 529 | +435 |
#' |
||
| 530 | +436 |
- #' @return+ #' @inheritParams g_forest |
||
| 531 | +437 |
- #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type.+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
||
| 532 | +438 |
- #'+ #' @param x (`numeric`)\cr coordinate of point. |
||
| 533 | +439 |
- #' @examples+ #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval. |
||
| 534 | +440 |
- #' summary_labels()+ #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol. |
||
| 535 | +441 |
- #' summary_labels(type = "counts", include_pval = TRUE)+ #' If `NULL`, the same symbol size is used. |
||
| 536 | +442 |
#' |
||
| 537 | +443 |
- #' @export+ #' @details |
||
| 538 | +444 |
- summary_labels <- function(type = "numeric", include_pval = FALSE) {
- |
- ||
| 539 | -2x | -
- lifecycle::deprecate_warn(- |
- ||
| 540 | -2x | -
- "0.9.6", "summary_formats()",- |
- ||
| 541 | -2x | -
- details = 'Use get_labels_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
+ #' The heights get automatically determined. |
||
| 542 | +445 |
- )- |
- ||
| 543 | -2x | -
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
- |
- ||
| 544 | -2x | -
- get_labels_from_stats(get_stats(met_grp, add_pval = include_pval))+ #' |
||
| 545 | +446 |
- }+ #' @examples |
| 1 | +447 |
- #' Create a forest plot from an `rtable`+ #' tbl <- rtable( |
||
| 2 | +448 |
- #'+ #' header = rheader( |
||
| 3 | +449 |
- #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2+ #' rrow("", "E", rcell("CI", colspan = 2), "N"),
|
||
| 4 | +450 |
- #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The+ #' rrow("", "A", "B", "C", "D")
|
||
| 5 | +451 |
- #' table and forest plot are printed side-by-side.+ #' ), |
||
| 6 | +452 |
- #'+ #' rrow("row 1", 1, 0.8, 1.1, 16),
|
||
| 7 | +453 |
- #' @description `r lifecycle::badge("stable")`
+ #' rrow("row 2", 1.4, 0.8, 1.6, 25),
|
||
| 8 | +454 |
- #'+ #' rrow("row 3", 1.2, 0.8, 1.6, 36)
|
||
| 9 | +455 |
- #' @inheritParams rtable2gg+ #' ) |
||
| 10 | +456 |
- #' @inheritParams argument_convention+ #' |
||
| 11 | +457 |
- #' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2+ #' x <- c(1, 1.4, 1.2) |
||
| 12 | +458 |
- #' values.+ #' lower <- c(0.8, 0.8, 0.8) |
||
| 13 | +459 |
- #' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from+ #' upper <- c(1.1, 1.6, 1.6) |
||
| 14 | +460 |
- #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded+ #' # numeric vector with multiplication factor to scale each circle radius |
||
| 15 | +461 |
- #' from forest plot.+ #' # default radius is 1/3.5 lines |
||
| 16 | +462 |
- #' @param col_ci (`integer(1)` or `NULL`)\cr column index with confidence intervals. By default tries to get this from+ #' symbol_scale <- c(1, 1.25, 1.5) |
||
| 17 | +463 |
- #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded+ #' |
||
| 18 | +464 |
- #' from forest plot.+ #' # Internal function - forest_grob |
||
| 19 | +465 |
- #' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted.+ #' \donttest{
|
||
| 20 | +466 |
- #' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively.+ #' p <- forest_grob(tbl, x, lower, upper, |
||
| 21 | +467 |
- #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute+ #' vline = 1, forest_header = c("A", "B"),
|
||
| 22 | +468 |
- #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to+ #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale, |
||
| 23 | +469 |
- #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not.+ #' vp = grid::plotViewport(margins = c(1, 1, 1, 1)) |
||
| 24 | +470 |
- #' @param xlim (`numeric(2)`)\cr limits for x axis.+ #' ) |
||
| 25 | +471 |
- #' @param logx (`flag`)\cr show the x-values on logarithm scale.+ #' |
||
| 26 | +472 |
- #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values.+ #' draw_grob(p) |
||
| 27 | +473 |
- #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
+ #' } |
||
| 28 | +474 |
- #' @param width_columns (`numeric`)\cr a vector of column widths. Each element's position in+ #' |
||
| 29 | +475 |
- #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated+ #' @noRd |
||
| 30 | +476 |
- #' according to maximum number of characters per column.+ #' @keywords internal |
||
| 31 | +477 |
- #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
+ forest_grob <- function(tbl, |
||
| 32 | +478 |
- #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative+ x, |
||
| 33 | +479 |
- #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored.+ lower, |
||
| 34 | +480 |
- #' @param font_size (`numeric(1)`)\cr font size.+ upper, |
||
| 35 | +481 |
- #' @param col_symbol_size (`numeric` or `NULL`)\cr column index from `tbl` containing data to be used+ vline, |
||
| 36 | +482 |
- #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional+ forest_header, |
||
| 37 | +483 |
- #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups.+ xlim = NULL, |
||
| 38 | +484 |
- #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified.+ logx = FALSE, |
||
| 39 | +485 |
- #' @param col (`character`)\cr color(s).+ x_at = NULL, |
||
| 40 | +486 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ width_row_names = NULL, |
||
| 41 | +487 |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list+ width_columns = NULL, |
||
| 42 | +488 |
- #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are+ width_forest = grid::unit(1, "null"), |
||
| 43 | +489 |
- #' printed side-by-side via [cowplot::plot_grid()].+ symbol_size = NULL, |
||
| 44 | +490 |
- #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ col = "blue", |
||
| 45 | +491 |
- #' is no longer used.+ name = NULL, |
||
| 46 | +492 |
- #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ gp = NULL, |
||
| 47 | +493 |
- #' is no longer used.+ vp = NULL) {
|
||
| 48 | -+ | |||
| 494 | +1x |
- #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ lifecycle::deprecate_warn( |
||
| 49 | -+ | |||
| 495 | +1x |
- #' is no longer used.+ "0.9.4", "forest_grob()", |
||
| 50 | -+ | |||
| 496 | +1x |
- #'+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 51 | +497 |
- #' @return `ggplot` forest plot and table.+ ) |
||
| 52 | +498 |
- #'+ |
||
| 53 | -+ | |||
| 499 | +1x |
- #' @examples+ nr <- nrow(tbl) |
||
| 54 | -+ | |||
| 500 | +1x |
- #' library(dplyr)+ if (is.null(vline)) {
|
||
| 55 | -+ | |||
| 501 | +! |
- #' library(forcats)+ checkmate::assert_true(is.null(forest_header)) |
||
| 56 | +502 |
- #'+ } else {
|
||
| 57 | -+ | |||
| 503 | +1x |
- #' adrs <- tern_ex_adrs+ checkmate::assert_number(vline) |
||
| 58 | -+ | |||
| 504 | +1x |
- #' n_records <- 20+ checkmate::assert_character(forest_header, len = 2, null.ok = TRUE) |
||
| 59 | +505 |
- #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE)+ } |
||
| 60 | +506 |
- #' adrs <- adrs %>%+ |
||
| 61 | -+ | |||
| 507 | +1x |
- #' filter(PARAMCD == "BESRSPI") %>%+ checkmate::assert_numeric(x, len = nr) |
||
| 62 | -+ | |||
| 508 | +1x |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ checkmate::assert_numeric(lower, len = nr) |
||
| 63 | -+ | |||
| 509 | +1x |
- #' slice(seq_len(n_records)) %>%+ checkmate::assert_numeric(upper, len = nr) |
||
| 64 | -+ | |||
| 510 | +1x |
- #' droplevels() %>%+ checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE) |
||
| 65 | -+ | |||
| 511 | +1x |
- #' mutate(+ checkmate::assert_character(col) |
||
| 66 | +512 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ |
||
| 67 | -+ | |||
| 513 | +1x |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ if (is.null(symbol_size)) {
|
||
| 68 | -+ | |||
| 514 | +! |
- #' rsp = AVALC == "CR"+ symbol_size <- rep(1, nr) |
||
| 69 | +515 |
- #' )+ } |
||
| 70 | +516 |
- #' formatters::var_labels(adrs) <- c(adrs_labels, "Response")+ |
||
| 71 | -+ | |||
| 517 | +1x |
- #' df <- extract_rsp_subgroups(+ if (is.null(xlim)) {
|
||
| 72 | -+ | |||
| 518 | +! |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
+ r <- range(c(x, lower, upper), na.rm = TRUE) |
||
| 73 | -+ | |||
| 519 | +! |
- #' data = adrs+ xlim <- r + c(-0.05, 0.05) * diff(r) |
||
| 74 | +520 |
- #' )+ } |
||
| 75 | +521 |
- #' # Full commonly used response table.+ |
||
| 76 | -+ | |||
| 522 | +1x |
- #'+ if (logx) {
|
||
| 77 | -+ | |||
| 523 | +1x |
- #' tbl <- basic_table() %>%+ if (is.null(x_at)) {
|
||
| 78 | -+ | |||
| 524 | +! |
- #' tabulate_rsp_subgroups(df)+ x_at <- pretty(log(stats::na.omit(c(x, lower, upper)))) |
||
| 79 | -+ | |||
| 525 | +! |
- #' g_forest(tbl)+ x_labels <- exp(x_at) |
||
| 80 | +526 |
- #'+ } else {
|
||
| 81 | -+ | |||
| 527 | +1x |
- #' # Odds ratio only table.+ x_labels <- x_at |
||
| 82 | -+ | |||
| 528 | +1x |
- #'+ x_at <- log(x_at) |
||
| 83 | +529 |
- #' tbl_or <- basic_table() %>%+ } |
||
| 84 | -+ | |||
| 530 | +1x |
- #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
+ xlim <- log(xlim) |
||
| 85 | -+ | |||
| 531 | +1x |
- #' g_forest(+ x <- log(x) |
||
| 86 | -+ | |||
| 532 | +1x |
- #' tbl_or,+ lower <- log(lower) |
||
| 87 | -+ | |||
| 533 | +1x |
- #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
+ upper <- log(upper) |
||
| 88 | -+ | |||
| 534 | +1x |
- #' )+ if (!is.null(vline)) {
|
||
| 89 | -+ | |||
| 535 | +1x |
- #'+ vline <- log(vline) |
||
| 90 | +536 |
- #' # Survival forest plot example.+ } |
||
| 91 | +537 |
- #' adtte <- tern_ex_adtte+ } else {
|
||
| 92 | -+ | |||
| 538 | +! |
- #' # Save variable labels before data processing steps.+ x_labels <- TRUE |
||
| 93 | +539 |
- #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE)+ } |
||
| 94 | +540 |
- #' adtte_f <- adtte %>%+ |
||
| 95 | -+ | |||
| 541 | +1x |
- #' filter(+ data_forest_vp <- grid::dataViewport(xlim, c(0, 1)) |
||
| 96 | +542 |
- #' PARAMCD == "OS",+ |
||
| 97 | +543 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ # Get table content as matrix form. |
||
| 98 | -+ | |||
| 544 | +1x |
- #' SEX %in% c("M", "F")
+ mf <- matrix_form(tbl) |
||
| 99 | +545 |
- #' ) %>%+ |
||
| 100 | +546 |
- #' mutate(+ # Use `rtables` indent_string eventually. |
||
| 101 | -+ | |||
| 547 | +1x |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ mf$strings[, 1] <- paste0( |
||
| 102 | -+ | |||
| 548 | +1x |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
|
||
| 103 | -+ | |||
| 549 | +1x |
- #' SEX = droplevels(SEX),+ mf$strings[, 1] |
||
| 104 | +550 |
- #' AVALU = as.character(AVALU),+ ) |
||
| 105 | +551 |
- #' is_event = CNSR == 0+ |
||
| 106 | -+ | |||
| 552 | +1x |
- #' )+ n_header <- attr(mf, "nrow_header") |
||
| 107 | +553 |
- #' labels <- list(+ |
||
| 108 | -+ | |||
| 554 | +! |
- #' "ARM" = adtte_labels["ARM"],+ if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
|
||
| 109 | +555 |
- #' "SEX" = adtte_labels["SEX"],+ |
||
| 110 | +556 |
- #' "AVALU" = adtte_labels["AVALU"],+ # Pre-process the data to be used in lapply and cell_in_rows. |
||
| 111 | -+ | |||
| 557 | +1x |
- #' "is_event" = "Event Flag"+ to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
|
||
| 112 | -+ | |||
| 558 | +1x |
- #' )+ underline_colspan = FALSE) {
|
||
| 113 | -+ | |||
| 559 | +2x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels)+ part <- match.arg(part) |
||
| 114 | -+ | |||
| 560 | +2x |
- #' df <- extract_survival_subgroups(+ if (part == "body") {
|
||
| 115 | -+ | |||
| 561 | +1x |
- #' variables = list(+ mat_row_indices <- seq_len(nrow(tbl)) + n_header |
||
| 116 | -+ | |||
| 562 | +1x |
- #' tte = "AVAL",+ row_ind_offset <- -n_header |
||
| 117 | +563 |
- #' is_event = "is_event",+ } else {
|
||
| 118 | -+ | |||
| 564 | +1x |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ mat_row_indices <- seq_len(n_header) |
||
| 119 | -+ | |||
| 565 | +1x |
- #' ),+ row_ind_offset <- 0 |
||
| 120 | +566 |
- #' data = adtte_f+ } |
||
| 121 | +567 |
- #' )+ |
||
| 122 | -+ | |||
| 568 | +2x |
- #' table_hr <- basic_table() %>%+ lapply(mat_row_indices, function(i) {
|
||
| 123 | -+ | |||
| 569 | +5x |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ disp <- mf$display[i, -1] |
||
| 124 | -+ | |||
| 570 | +5x |
- #' g_forest(table_hr)+ list( |
||
| 125 | -+ | |||
| 571 | +5x |
- #'+ row_name = mf$strings[i, 1], |
||
| 126 | -+ | |||
| 572 | +5x |
- #' # Works with any `rtable`.+ cells = mf$strings[i, -1][disp], |
||
| 127 | -+ | |||
| 573 | +5x |
- #' tbl <- rtable(+ cell_spans = mf$spans[i, -1][disp], |
||
| 128 | -+ | |||
| 574 | +5x |
- #' header = c("E", "CI", "N"),
+ row_index = i + row_ind_offset, |
||
| 129 | -+ | |||
| 575 | +5x |
- #' rrow("", 1, c(.8, 1.2), 200),
+ underline_colspan = underline_colspan |
||
| 130 | +576 |
- #' rrow("", 1.2, c(1.1, 1.4), 50)
+ ) |
||
| 131 | +577 |
- #' )+ }) |
||
| 132 | +578 |
- #' g_forest(+ } |
||
| 133 | +579 |
- #' tbl = tbl,+ |
||
| 134 | -+ | |||
| 580 | +1x |
- #' col_x = 1,+ args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
|
||
| 135 | -+ | |||
| 581 | +1x |
- #' col_ci = 2,+ args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
|
||
| 136 | +582 |
- #' xlim = c(0.5, 2),+ |
||
| 137 | -+ | |||
| 583 | +1x |
- #' x_at = c(0.5, 1, 2),+ grid::gTree( |
||
| 138 | -+ | |||
| 584 | +1x |
- #' col_symbol_size = 3+ name = name, |
||
| 139 | -+ | |||
| 585 | +1x |
- #' )+ children = grid::gList( |
||
| 140 | -+ | |||
| 586 | +1x |
- #'+ grid::gTree( |
||
| 141 | -+ | |||
| 587 | +1x |
- #' tbl <- rtable(+ children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)), |
||
| 142 | -+ | |||
| 588 | +1x |
- #' header = rheader(+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
||
| 143 | +589 |
- #' rrow("", rcell("A", colspan = 2)),
+ ), |
||
| 144 | -+ | |||
| 590 | +1x |
- #' rrow("", "c1", "c2")
+ grid::gTree( |
||
| 145 | -+ | |||
| 591 | +1x |
- #' ),+ children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)), |
||
| 146 | -+ | |||
| 592 | +1x |
- #' rrow("row 1", 1, c(.8, 1.2)),
+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
||
| 147 | +593 |
- #' rrow("row 2", 1.2, c(1.1, 1.4))
+ ), |
||
| 148 | -+ | |||
| 594 | +1x |
- #' )+ grid::linesGrob( |
||
| 149 | -+ | |||
| 595 | +1x |
- #' g_forest(+ grid::unit(c(0, 1), "npc"), |
||
| 150 | -+ | |||
| 596 | +1x |
- #' tbl = tbl,+ y = grid::unit(c(.5, .5), "npc"), |
||
| 151 | -+ | |||
| 597 | +1x |
- #' col_x = 1,+ vp = grid::vpPath("vp_table_layout", "vp_spacer")
|
||
| 152 | +598 |
- #' col_ci = 2,+ ), |
||
| 153 | +599 |
- #' xlim = c(0.5, 2),+ # forest part |
||
| 154 | -+ | |||
| 600 | +1x |
- #' x_at = c(0.5, 1, 2),+ if (is.null(vline)) {
|
||
| 155 | -+ | |||
| 601 | +! |
- #' vline = 1,+ NULL |
||
| 156 | +602 |
- #' forest_header = c("Hello", "World")
+ } else {
|
||
| 157 | -+ | |||
| 603 | +1x |
- #' )+ grid::gTree( |
||
| 158 | -+ | |||
| 604 | +1x |
- #'+ children = grid::gList( |
||
| 159 | -+ | |||
| 605 | +1x |
- #' @export+ grid::gTree( |
||
| 160 | -+ | |||
| 606 | +1x |
- g_forest <- function(tbl,+ children = grid::gList( |
||
| 161 | +607 |
- col_x = attr(tbl, "col_x"),+ # this may overflow, to fix, look here |
||
| 162 | +608 |
- col_ci = attr(tbl, "col_ci"),+ # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint |
||
| 163 | -+ | |||
| 609 | +1x |
- vline = 1,+ grid::textGrob( |
||
| 164 | -+ | |||
| 610 | +1x |
- forest_header = attr(tbl, "forest_header"),+ forest_header[1], |
||
| 165 | -+ | |||
| 611 | +1x |
- xlim = c(0.1, 10),+ x = grid::unit(vline, "native") - grid::unit(1, "lines"), |
||
| 166 | -+ | |||
| 612 | +1x |
- logx = TRUE,+ just = c("right", "center")
|
||
| 167 | +613 |
- x_at = c(0.1, 1, 10),+ ), |
||
| 168 | -+ | |||
| 614 | +1x |
- width_row_names = lifecycle::deprecated(),+ grid::textGrob( |
||
| 169 | -+ | |||
| 615 | +1x |
- width_columns = NULL,+ forest_header[2], |
||
| 170 | -+ | |||
| 616 | +1x |
- width_forest = lifecycle::deprecated(),+ x = grid::unit(vline, "native") + grid::unit(1, "lines"), |
||
| 171 | -+ | |||
| 617 | +1x |
- lbl_col_padding = 0,+ just = c("left", "center")
|
||
| 172 | +618 |
- rel_width_forest = 0.25,+ ) |
||
| 173 | +619 |
- font_size = 12,+ ), |
||
| 174 | -+ | |||
| 620 | +1x |
- col_symbol_size = attr(tbl, "col_symbol_size"),+ vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp) |
||
| 175 | +621 |
- col = getOption("ggplot2.discrete.colour")[1],
+ ) |
||
| 176 | +622 |
- ggtheme = NULL,+ ), |
||
| 177 | -+ | |||
| 623 | +1x |
- as_list = FALSE,+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
||
| 178 | +624 |
- gp = lifecycle::deprecated(),+ ) |
||
| 179 | +625 |
- draw = lifecycle::deprecated(),+ }, |
||
| 180 | -+ | |||
| 626 | +1x |
- newpage = lifecycle::deprecated()) {
+ grid::gTree( |
||
| 181 | -+ | |||
| 627 | +1x |
- # Deprecated argument warnings+ children = grid::gList( |
||
| 182 | -4x | +628 | +1x |
- if (lifecycle::is_present(width_row_names)) {
+ grid::gTree( |
| 183 | +629 | 1x |
- lifecycle::deprecate_warn(+ children = grid::gList( |
|
| 184 | +630 | 1x |
- "0.9.4", "g_forest(width_row_names)", "g_forest(lbl_col_padding)",+ grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")), |
|
| 185 | +631 | 1x |
- details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter."+ if (is.null(vline)) {
|
|
| 186 | -+ | |||
| 632 | +! |
- )+ NULL |
||
| 187 | +633 |
- }+ } else {
|
||
| 188 | -4x | +634 | +1x |
- if (lifecycle::is_present(width_forest)) {
+ grid::linesGrob( |
| 189 | +635 | 1x |
- lifecycle::deprecate_warn(+ x = grid::unit(rep(vline, 2), "native"), |
|
| 190 | +636 | 1x |
- "0.9.4", "g_forest(width_forest)", "g_forest(rel_width_forest)",+ y = grid::unit(c(0, 1), "npc"), |
|
| 191 | +637 | 1x |
- details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter."+ gp = grid::gpar(lwd = 2), |
|
| 192 | -+ | |||
| 638 | +1x |
- )+ vp = data_forest_vp |
||
| 193 | +639 |
- }- |
- ||
| 194 | -4x | -
- if (lifecycle::is_present(gp)) {
+ ) |
||
| 195 | -1x | +|||
| 640 | +
- lifecycle::deprecate_warn(+ }, |
|||
| 196 | +641 | 1x |
- "0.9.4", "g_forest(gp)", "g_forest(ggtheme)",+ grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp) |
|
| 197 | -1x | +|||
| 642 | +
- details = paste(+ ), |
|||
| 198 | +643 | 1x |
- "`g_forest` is now generated as a `ggplot` object.",+ vp = grid::viewport(layout.pos.col = ncol(tbl) + 2) |
|
| 199 | -1x | +|||
| 644 | +
- "Additional display settings should be supplied via the `ggtheme` parameter."+ ) |
|||
| 200 | +645 |
- )+ ), |
||
| 201 | -+ | |||
| 646 | +1x |
- )+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
||
| 202 | +647 |
- }+ ), |
||
| 203 | -4x | +648 | +1x |
- if (lifecycle::is_present(draw)) {
+ grid::gTree( |
| 204 | +649 | 1x |
- lifecycle::deprecate_warn(+ children = do.call( |
|
| 205 | +650 | 1x |
- "0.9.4", "g_forest(draw)",+ grid::gList, |
|
| 206 | +651 | 1x |
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."+ Map( |
|
| 207 | -+ | |||
| 652 | +1x |
- )+ function(xi, li, ui, row_index, size_i, col) {
|
||
| 208 | -+ | |||
| 653 | +3x |
- }+ forest_dot_line( |
||
| 209 | -4x | +654 | +3x |
- if (lifecycle::is_present(newpage)) {
+ xi, |
| 210 | -1x | +655 | +3x |
- lifecycle::deprecate_warn(+ li, |
| 211 | -1x | +656 | +3x |
- "0.9.4", "g_forest(newpage)",+ ui, |
| 212 | -1x | -
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."- |
- ||
| 213 | -+ | 657 | +3x |
- )+ row_index, |
| 214 | -+ | |||
| 658 | +3x |
- }+ xlim, |
||
| 215 | -+ | |||
| 659 | +3x |
-
+ symbol_size = size_i, |
||
| 216 | -4x | +660 | +3x |
- checkmate::assert_class(tbl, "VTableTree")+ col = col, |
| 217 | -4x | +661 | +3x |
- checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ datavp = data_forest_vp |
| 218 | -4x | +|||
| 662 | +
- checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ ) |
|||
| 219 | -4x | +|||
| 663 | +
- checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ }, |
|||
| 220 | -4x | +664 | +1x |
- checkmate::assert_number(font_size, lower = 0)+ x, |
| 221 | -4x | +665 | +1x |
- checkmate::assert_character(col, null.ok = TRUE)+ lower, |
| 222 | -4x | +666 | +1x |
- checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl))+ upper, |
| 223 | -+ | |||
| 667 | +1x |
-
+ seq_along(x), |
||
| 224 | -+ | |||
| 668 | +1x |
- # Extract info from table+ symbol_size, |
||
| 225 | -4x | +669 | +1x |
- mat <- matrix_form(tbl, indent_rownames = TRUE)+ col, |
| 226 | -4x | +670 | +1x |
- mat_strings <- formatters::mf_strings(mat)+ USE.NAMES = FALSE |
| 227 | -4x | +|||
| 671 | +
- nlines_hdr <- formatters::mf_nlheader(mat)+ ) |
|||
| 228 | -4x | +|||
| 672 | +
- nrows_body <- nrow(mat_strings) - nlines_hdr+ ), |
|||
| 229 | -4x | +673 | +1x |
- tbl_stats <- mat_strings[nlines_hdr, -1]+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
| 230 | +674 |
-
+ ) |
||
| 231 | +675 |
- # Generate and modify table as ggplot object+ ), |
||
| 232 | -4x | +676 | +1x |
- gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) ++ childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest), |
| 233 | -4x | +677 | +1x |
- theme(plot.margin = margin(0, 0, 0, 0.025, "npc"))+ vp = vp, |
| 234 | -4x | +678 | +1x |
- gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01)+ gp = gp |
| 235 | -4x | +|||
| 679 | +
- gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1+ ) |
|||
| 236 | -4x | +|||
| 680 | +
- if (nlines_hdr == 2) {
+ } |
|||
| 237 | -4x | +|||
| 681 | +
- gg_table$scales$scales[[2]]$expand <- c(0, 0)+ |
|||
| 238 | -4x | +|||
| 682 | +
- arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))])+ cell_in_rows <- function(row_name, |
|||
| 239 | +683 |
- } else {
+ cells, |
||
| 240 | -! | +|||
| 684 | +
- arms <- NULL+ cell_spans, |
|||
| 241 | +685 |
- }+ row_index, |
||
| 242 | +686 |
-
+ underline_colspan = FALSE) {
|
||
| 243 | -4x | +687 | +5x |
- tbl_df <- as_result_df(tbl)+ checkmate::assert_string(row_name) |
| 244 | -4x | +688 | +5x |
- dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df))+ checkmate::assert_character(cells, min.len = 1, any.missing = FALSE) |
| 245 | -4x | +689 | +5x |
- tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)]+ checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE) |
| 246 | -4x | +690 | +5x |
- names(tbl_df) <- c("row_num", tbl_stats)
+ checkmate::assert_number(row_index) |
| 247 | -+ | |||
| 691 | +5x |
-
+ checkmate::assert_flag(underline_colspan) |
||
| 248 | +692 |
- # Check table data columns+ |
||
| 249 | -4x | +693 | +5x |
- if (!is.null(col_ci)) {
+ vp_name_rn <- paste0("rowname-", row_index)
|
| 250 | -4x | -
- ci_col <- col_ci + 1- |
- ||
| 251 | -+ | 694 | +5x |
- } else {
+ g_rowname <- if (!is.null(row_name) && row_name != "") {
|
| 252 | -! | +|||
| 695 | +3x |
- tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df))+ grid::textGrob( |
||
| 253 | -! | +|||
| 696 | +3x |
- ci_col <- which(names(tbl_df) == "empty_ci")+ name = vp_name_rn, |
||
| 254 | -+ | |||
| 697 | +3x |
- }+ label = row_name, |
||
| 255 | -! | +|||
| 698 | +3x |
- if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
+ x = grid::unit(0, "npc"), |
||
| 256 | -+ | |||
| 699 | +3x |
-
+ just = c("left", "center"),
|
||
| 257 | -4x | +700 | +3x |
- if (!is.null(col_x)) {
+ vp = grid::vpPath(paste0("rowname-", row_index))
|
| 258 | -4x | +|||
| 701 | +
- x_col <- col_x + 1+ ) |
|||
| 259 | +702 |
} else {
|
||
| 260 | -! | +|||
| 703 | +2x |
- tbl_df[["empty_x"]] <- NA_real_+ NULL |
||
| 261 | -! | +|||
| 704 | +
- x_col <- which(names(tbl_df) == "empty_x")+ } |
|||
| 262 | +705 |
- }+ |
||
| 263 | -4x | +706 | +5x |
- if (!is.null(col_symbol_size)) {
+ gl_cols <- if (!(length(cells) > 0)) {
|
| 264 | -3x | +|||
| 707 | +! |
- sym_size <- unlist(tbl_df[, col_symbol_size + 1])+ list(NULL) |
||
| 265 | +708 |
} else {
|
||
| 266 | -1x | -
- sym_size <- rep(1, nrow(tbl_df))- |
- ||
| 267 | -+ | 709 | +5x |
- }+ j <- 1 # column index of cell |
| 268 | +710 | |||
| 269 | -4x | -
- tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
- |
- ||
| 270 | -4x | -
- x <- unlist(tbl_df[, x_col])- |
- ||
| 271 | -4x | +711 | +5x |
- lwr <- unlist(tbl_df[["ci_lwr"]])+ lapply(seq_along(cells), function(k) {
|
| 272 | -4x | +712 | +19x |
- upr <- unlist(tbl_df[["ci_upr"]])+ cell_ascii <- cells[[k]] |
| 273 | -4x | +713 | +19x |
- row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2)+ cs <- cell_spans[[k]] |
| 274 | +714 | |||
| 275 | -! | -
- if (is.null(col)) col <- "#343cff"- |
- ||
| 276 | -4x | +715 | +19x |
- if (length(col) == 1) col <- rep(col, nrow(tbl_df))+ if (is.na(cell_ascii) || is.null(cell_ascii)) {
|
| 277 | +716 | ! |
- if (is.null(x_at)) x_at <- union(xlim, vline)- |
- |
| 278 | -4x | -
- x_labels <- x_at+ cell_ascii <- "NA" |
||
| 279 | +717 |
-
+ } |
||
| 280 | +718 |
- # Apply log transformation- |
- ||
| 281 | -4x | -
- if (logx) {
+
|
||
| 282 | -4x | +719 | +19x |
- x_t <- log(x)+ cell_name <- paste0("g-cell-", row_index, "-", j)
|
| 283 | -4x | +|||
| 720 | +
- lwr_t <- log(lwr)+ |
|||
| 284 | -4x | +721 | +19x |
- upr_t <- log(upr)+ cell_grobs <- if (identical(cell_ascii, "")) {
|
| 285 | -4x | +|||
| 722 | +! |
- xlim_t <- log(xlim)+ NULL |
||
| 286 | +723 |
- } else {
+ } else {
|
||
| 287 | -! | +|||
| 724 | +19x |
- x_t <- x+ if (cs == 1) {
|
||
| 288 | -! | +|||
| 725 | +18x |
- lwr_t <- lwr+ grid::textGrob( |
||
| 289 | -! | +|||
| 726 | +18x |
- upr_t <- upr+ label = cell_ascii, |
||
| 290 | -! | +|||
| 727 | +18x |
- xlim_t <- xlim+ name = cell_name, |
||
| 291 | -+ | |||
| 728 | +18x |
- }+ vp = grid::vpPath(paste0("cell-", row_index, "-", j))
|
||
| 292 | +729 |
-
+ ) |
||
| 293 | +730 |
- # Set up plot area- |
- ||
| 294 | -4x | -
- gg_plt <- ggplot(data = tbl_df) ++ } else {
|
||
| 295 | -4x | +|||
| 731 | +
- theme(+ # +1 because of rowname |
|||
| 296 | -4x | +732 | +1x |
- panel.background = element_rect(fill = "transparent", color = NA_character_),+ vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs)) |
| 297 | -4x | +|||
| 733 | +
- plot.background = element_rect(fill = "transparent", color = NA_character_),+ |
|||
| 298 | -4x | +734 | +1x |
- panel.grid.major = element_blank(),+ lab <- grid::textGrob( |
| 299 | -4x | +735 | +1x |
- panel.grid.minor = element_blank(),+ label = cell_ascii, |
| 300 | -4x | +736 | +1x |
- axis.title.x = element_blank(),+ name = cell_name, |
| 301 | -4x | +737 | +1x |
- axis.title.y = element_blank(),+ vp = vp_joined_cols |
| 302 | -4x | +|||
| 738 | +
- axis.line.x = element_line(),+ ) |
|||
| 303 | -4x | +|||
| 739 | +
- axis.text = element_text(size = font_size),+ |
|||
| 304 | -4x | +740 | +1x |
- legend.position = "none",+ if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
|
| 305 | -4x | +|||
| 741 | +! |
- plot.margin = margin(0, 0.1, 0.05, 0, "npc")+ lab |
||
| 306 | +742 |
- ) ++ } else {
|
||
| 307 | -4x | +743 | +1x |
- scale_x_continuous(+ grid::gList( |
| 308 | -4x | +744 | +1x |
- transform = ifelse(logx, "log", "identity"),+ lab, |
| 309 | -4x | +745 | +1x |
- limits = xlim,+ grid::linesGrob( |
| 310 | -4x | +746 | +1x |
- breaks = x_at,+ x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")), |
| 311 | -4x | +747 | +1x |
- labels = x_labels,+ y = grid::unit(c(0, 0), "npc"), |
| 312 | -4x | +748 | +1x |
- expand = c(0.01, 0)+ vp = vp_joined_cols |
| 313 | +749 |
- ) +- |
- ||
| 314 | -4x | -
- scale_y_continuous(+ ) |
||
| 315 | -4x | +|||
| 750 | +
- limits = c(0, nrow(mat_strings) + 1),+ ) |
|||
| 316 | -4x | +|||
| 751 | +
- breaks = NULL,+ } |
|||
| 317 | -4x | +|||
| 752 | +
- expand = c(0, 0)+ } |
|||
| 318 | +753 |
- ) ++ } |
||
| 319 | -4x | +754 | +19x |
- coord_cartesian(clip = "off")+ j <<- j + cs |
| 320 | +755 | |||
| 321 | -4x | +756 | +19x |
- if (is.null(ggtheme)) {
+ cell_grobs |
| 322 | -4x | +|||
| 757 | +
- gg_plt <- gg_plt + annotate(+ }) |
|||
| 323 | -4x | +|||
| 758 | +
- "rect",+ } |
|||
| 324 | -4x | +|||
| 759 | +
- xmin = xlim[1],+ |
|||
| 325 | -4x | +760 | +5x |
- xmax = xlim[2],+ grid::gList( |
| 326 | -4x | +761 | +5x |
- ymin = 0,+ g_rowname, |
| 327 | -4x | +762 | +5x |
- ymax = nrows_body + 0.5,+ do.call(grid::gList, gl_cols) |
| 328 | -4x | +|||
| 763 | +
- fill = "grey92"+ ) |
|||
| 329 | +764 |
- )+ } |
||
| 330 | +765 |
- }+ |
||
| 331 | +766 |
-
+ #' Graphic object: forest dot line |
||
| 332 | -4x | +|||
| 767 | +
- if (!is.null(vline)) {
+ #' |
|||
| 333 | +768 |
- # Set default forest header+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 334 | -4x | +|||
| 769 | +
- if (is.null(forest_header)) {
+ #' |
|||
| 335 | -! | +|||
| 770 | +
- forest_header <- c(+ #' Calculate the `grob` corresponding to the dot line within the forest plot. |
|||
| 336 | -! | +|||
| 771 | +
- paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"),+ #' |
|||
| 337 | -! | +|||
| 772 | +
- paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n")+ #' @noRd |
|||
| 338 | +773 |
- )+ #' @keywords internal |
||
| 339 | +774 |
- }+ forest_dot_line <- function(x, |
||
| 340 | +775 |
-
+ lower, |
||
| 341 | +776 |
- # Add vline and forest header labels+ upper, |
||
| 342 | -4x | +|||
| 777 | +
- mid_pts <- if (logx) {
+ row_index, |
|||
| 343 | -4x | +|||
| 778 | +
- c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2])))))+ xlim, |
|||
| 344 | +779 |
- } else {
+ symbol_size = 1, |
||
| 345 | -! | +|||
| 780 | +
- c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2])))+ col = "blue", |
|||
| 346 | +781 |
- }+ datavp) {
|
||
| 347 | -4x | +782 | +3x |
- gg_plt <- gg_plt ++ lifecycle::deprecate_warn( |
| 348 | -4x | +783 | +3x |
- annotate(+ "0.9.4", "forest_dot_line()", |
| 349 | -4x | +784 | +3x |
- "segment",+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 350 | -4x | +|||
| 785 | +
- x = vline, xend = vline, y = 0, yend = nrows_body + 0.5+ ) |
|||
| 351 | +786 |
- ) ++ |
||
| 352 | -4x | +787 | +3x |
- annotate(+ ci <- c(lower, upper) |
| 353 | -4x | +788 | +3x |
- "text",+ if (any(!is.na(c(x, ci)))) {
|
| 354 | -4x | +|||
| 789 | +
- x = mid_pts[1], y = nrows_body + 1.25,+ # line |
|||
| 355 | -4x | +790 | +3x |
- label = forest_header[1],+ y <- grid::unit(c(0.5, 0.5), "npc") |
| 356 | -4x | +|||
| 791 | +
- size = font_size / .pt,+ |
|||
| 357 | -4x | +792 | +3x |
- lineheight = 0.9+ g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
|
| 358 | +793 |
- ) ++ # - |
||
| 359 | -4x | +794 | +3x |
- annotate(+ if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
|
| 360 | -4x | +795 | +3x |
- "text",+ grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y) |
| 361 | -4x | +|||
| 796 | +! |
- x = mid_pts[2], y = nrows_body + 1.25,+ } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
|
||
| 362 | -4x | +|||
| 797 | +
- label = forest_header[2],+ # <-> |
|||
| 363 | -4x | +|||
| 798 | +! |
- size = font_size / .pt,+ grid::linesGrob( |
||
| 364 | -4x | +|||
| 799 | +! |
- lineheight = 0.9+ x = grid::unit(xlim, "native"), |
||
| 365 | -+ | |||
| 800 | +! |
- )+ y = y, |
||
| 366 | -+ | |||
| 801 | +! |
- }+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both") |
||
| 367 | +802 |
-
+ )+ |
+ ||
| 803 | +! | +
+ } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
|
||
| 368 | +804 |
- # Add points to plot+ # <- |
||
| 369 | -4x | +|||
| 805 | +! |
- if (any(!is.na(x_t))) {
+ grid::linesGrob( |
||
| 370 | -4x | -
- x_t[x < xlim[1] | x > xlim[2]] <- NA- |
- ||
| 371 | -4x | -
- gg_plt <- gg_plt + geom_point(- |
- ||
| 372 | -4x | -
- x = x_t,- |
- ||
| 373 | -4x | -
- y = row_num,- |
- ||
| 374 | -4x | -
- color = col,- |
- ||
| 375 | -4x | -
- aes(size = sym_size),- |
- ||
| 376 | -4x | +|||
| 806 | +! |
- na.rm = TRUE+ x = grid::unit(c(xlim[1], ci[2]), "native"), |
||
| 377 | -+ | |||
| 807 | +! |
- )+ y = y, |
||
| 378 | -+ | |||
| 808 | +! |
- }+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first") |
||
| 379 | +809 |
-
+ ) |
||
| 380 | -4x | +|||
| 810 | +! |
- for (i in seq_len(nrow(tbl_df))) {
+ } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
|
||
| 381 | +811 |
- # Determine which arrow(s) to add to CI lines- |
- ||
| 382 | -17x | -
- which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2])- |
- ||
| 383 | -17x | -
- which_arrow <- dplyr::case_when(+ # -> |
||
| 384 | -17x | +|||
| 812 | +! |
- all(which_arrow) ~ "both",+ grid::linesGrob( |
||
| 385 | -17x | +|||
| 813 | +! |
- which_arrow[1] ~ "first",+ x = grid::unit(c(ci[1], xlim[2]), "native"), |
||
| 386 | -17x | +|||
| 814 | +! |
- which_arrow[2] ~ "last",+ y = y, |
||
| 387 | -17x | +|||
| 815 | +! |
- TRUE ~ NA_character_+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last") |
||
| 388 | +816 |
- )+ ) |
||
| 389 | +817 |
-
+ } |
||
| 390 | +818 |
- # Add CI lines- |
- ||
| 391 | -17x | -
- gg_plt <- gg_plt +- |
- ||
| 392 | -17x | -
- if (!is.na(which_arrow)) {
- |
- ||
| 393 | -15x | -
- annotate(- |
- ||
| 394 | -15x | -
- "segment",- |
- ||
| 395 | -15x | -
- x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
- |
- ||
| 396 | -15x | -
- xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
- |
- ||
| 397 | -15x | -
- y = row_num[i], yend = row_num[i],- |
- ||
| 398 | -15x | -
- color = if (length(col) == 1) col else col[i],- |
- ||
| 399 | -15x | -
- arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow),+ } else {
|
||
| 400 | -15x | +|||
| 819 | +! |
- na.rm = TRUE+ NULL |
||
| 401 | +820 |
- )+ } |
||
| 402 | +821 |
- } else {
+
|
||
| 403 | -2x | +822 | +3x |
- annotate(+ g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
|
| 404 | -2x | +823 | +3x |
- "segment",+ grid::circleGrob( |
| 405 | -2x | +824 | +3x |
- x = lwr[i], xend = upr[i],+ x = grid::unit(x, "native"), |
| 406 | -2x | +825 | +3x |
- y = row_num[i], yend = row_num[i],+ y = y, |
| 407 | -2x | +826 | +3x |
- color = if (length(col) == 1) col else col[i],+ r = grid::unit(1 / 3.5 * symbol_size, "lines"), |
| 408 | -2x | +827 | +3x |
- na.rm = TRUE+ name = "point" |
| 409 | +828 |
- )+ ) |
||
| 410 | +829 |
- }+ } else {
+ |
+ ||
| 830 | +! | +
+ NULL |
||
| 411 | +831 |
- }+ } |
||
| 412 | +832 | |||
| 413 | -+ | |||
| 833 | +3x |
- # Apply custom ggtheme to plot+ grid::gTree( |
||
| 414 | -! | +|||
| 834 | +3x |
- if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ children = grid::gList( |
||
| 415 | -+ | |||
| 835 | +3x |
-
+ grid::gTree( |
||
| 416 | -4x | +836 | +3x |
- if (as_list) {
+ children = grid::gList( |
| 417 | -1x | +837 | +3x |
- list(+ grid::gList( |
| 418 | -1x | +838 | +3x |
- table = gg_table,+ g_line, |
| 419 | -1x | +839 | +3x |
- plot = gg_plt+ g_circle |
| 420 | +840 |
- )+ ) |
||
| 421 | +841 |
- } else {
+ ), |
||
| 422 | +842 | 3x |
- cowplot::plot_grid(+ vp = datavp, |
|
| 423 | +843 | 3x |
- gg_table,+ gp = grid::gpar(col = col, fill = col) |
|
| 424 | -3x | +|||
| 844 | +
- gg_plt,+ ) |
|||
| 425 | -3x | +|||
| 845 | +
- align = "h",+ ), |
|||
| 426 | +846 | 3x |
- axis = "tblr",+ vp = grid::vpPath(paste0("forest-", row_index))
|
|
| 427 | -3x | +|||
| 847 | +
- rel_widths = c(1 - rel_width_forest, rel_width_forest)+ ) |
|||
| 428 | +848 |
- )+ } else {
+ |
+ ||
| 849 | +! | +
+ NULL |
||
| 429 | +850 |
} |
||
| 430 | +851 |
} |
||
| 431 | +852 | |||
| 432 | +853 |
- #' Forest plot grob+ #' Create a viewport tree for the forest plot |
||
| 433 | +854 |
#' |
||
| 434 | +855 |
#' @description `r lifecycle::badge("deprecated")`
|
||
| 435 | +856 |
#' |
||
| 436 | +857 |
- #' @inheritParams g_forest+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
||
| 437 | +858 |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ #' @param width_row_names (`grid::unit`)\cr width of row names. |
||
| 438 | +859 |
- #' @param x (`numeric`)\cr coordinate of point.+ #' @param width_columns (`grid::unit`)\cr width of column spans. |
||
| 439 | +860 |
- #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval.+ #' @param width_forest (`grid::unit`)\cr width of the forest plot. |
||
| 440 | +861 |
- #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol.+ #' @param gap_column (`grid::unit`)\cr gap width between the columns. |
||
| 441 | +862 |
- #' If `NULL`, the same symbol size is used.+ #' @param gap_header (`grid::unit`)\cr gap width between the header. |
||
| 442 | +863 |
- #'+ #' @param mat_form (`MatrixPrintForm`)\cr matrix print form of the table. |
||
| 443 | +864 |
- #' @details+ #' |
||
| 444 | +865 |
- #' The heights get automatically determined.+ #' @return A viewport tree. |
||
| 445 | +866 |
#' |
||
| 446 | +867 |
#' @examples |
||
| 447 | +868 | ++ |
+ #' library(grid)+ |
+ |
| 869 | ++ |
+ #'+ |
+ ||
| 870 |
#' tbl <- rtable( |
|||
| 448 | +871 |
#' header = rheader( |
||
| 449 | +872 |
- #' rrow("", "E", rcell("CI", colspan = 2), "N"),
+ #' rrow("", "E", rcell("CI", colspan = 2)),
|
||
| 450 | +873 |
- #' rrow("", "A", "B", "C", "D")
+ #' rrow("", "A", "B", "C")
|
||
| 451 | +874 |
#' ), |
||
| 452 | +875 |
- #' rrow("row 1", 1, 0.8, 1.1, 16),
+ #' rrow("row 1", 1, 0.8, 1.1),
|
||
| 453 | +876 |
- #' rrow("row 2", 1.4, 0.8, 1.6, 25),
+ #' rrow("row 2", 1.4, 0.8, 1.6),
|
||
| 454 | +877 |
- #' rrow("row 3", 1.2, 0.8, 1.6, 36)
+ #' rrow("row 3", 1.2, 0.8, 1.2)
|
||
| 455 | +878 |
#' ) |
||
| 456 | +879 |
#' |
||
| 457 | +880 |
- #' x <- c(1, 1.4, 1.2)+ #' \donttest{
|
||
| 458 | +881 |
- #' lower <- c(0.8, 0.8, 0.8)+ #' v <- forest_viewport(tbl) |
||
| 459 | +882 |
- #' upper <- c(1.1, 1.6, 1.6)+ #' |
||
| 460 | +883 |
- #' # numeric vector with multiplication factor to scale each circle radius+ #' grid::grid.newpage() |
||
| 461 | +884 |
- #' # default radius is 1/3.5 lines+ #' showViewport(v) |
||
| 462 | +885 |
- #' symbol_scale <- c(1, 1.25, 1.5)+ #' } |
||
| 463 | +886 |
#' |
||
| 464 | +887 |
- #' # Internal function - forest_grob+ #' @export |
||
| 465 | +888 |
- #' \donttest{
+ forest_viewport <- function(tbl, |
||
| 466 | +889 |
- #' p <- forest_grob(tbl, x, lower, upper,+ width_row_names = NULL, |
||
| 467 | +890 |
- #' vline = 1, forest_header = c("A", "B"),
+ width_columns = NULL, |
||
| 468 | +891 |
- #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale,+ width_forest = grid::unit(1, "null"), |
||
| 469 | +892 |
- #' vp = grid::plotViewport(margins = c(1, 1, 1, 1))+ gap_column = grid::unit(1, "lines"), |
||
| 470 | +893 |
- #' )+ gap_header = grid::unit(1, "lines"), |
||
| 471 | +894 |
- #'+ mat_form = NULL) {
|
||
| 472 | -+ | |||
| 895 | +2x |
- #' draw_grob(p)+ lifecycle::deprecate_warn( |
||
| 473 | -+ | |||
| 896 | +2x |
- #' }+ "0.9.4", |
||
| 474 | -+ | |||
| 897 | +2x |
- #'+ "forest_viewport()", |
||
| 475 | -+ | |||
| 898 | +2x |
- #' @noRd+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 476 | +899 |
- #' @keywords internal+ ) |
||
| 477 | +900 |
- forest_grob <- function(tbl,+ |
||
| 478 | -+ | |||
| 901 | +2x |
- x,+ checkmate::assert_class(tbl, "VTableTree") |
||
| 479 | -+ | |||
| 902 | +2x |
- lower,+ checkmate::assert_true(grid::is.unit(width_forest)) |
||
| 480 | -+ | |||
| 903 | +2x |
- upper,+ if (!is.null(width_row_names)) {
|
||
| 481 | -+ | |||
| 904 | +! |
- vline,+ checkmate::assert_true(grid::is.unit(width_row_names)) |
||
| 482 | +905 |
- forest_header,+ } |
||
| 483 | -+ | |||
| 906 | +2x |
- xlim = NULL,+ if (!is.null(width_columns)) {
|
||
| 484 | -+ | |||
| 907 | +! |
- logx = FALSE,+ checkmate::assert_true(grid::is.unit(width_columns)) |
||
| 485 | +908 |
- x_at = NULL,+ } |
||
| 486 | +909 |
- width_row_names = NULL,+ |
||
| 487 | -+ | |||
| 910 | +2x |
- width_columns = NULL,+ if (is.null(mat_form)) mat_form <- matrix_form(tbl) |
||
| 488 | +911 |
- width_forest = grid::unit(1, "null"),+ |
||
| 489 | -+ | |||
| 912 | +2x |
- symbol_size = NULL,+ mat_form$strings[!mat_form$display] <- "" |
||
| 490 | +913 |
- col = "blue",+ |
||
| 491 | -+ | |||
| 914 | +2x |
- name = NULL,+ nr <- nrow(tbl) |
||
| 492 | -+ | |||
| 915 | +2x |
- gp = NULL,+ nc <- ncol(tbl)+ |
+ ||
| 916 | +2x | +
+ nr_h <- attr(mat_form, "nrow_header") |
||
| 493 | +917 |
- vp = NULL) {
+
|
||
| 494 | -1x | +918 | +2x |
- lifecycle::deprecate_warn(+ if (is.null(width_row_names) || is.null(width_columns)) {
|
| 495 | -1x | +919 | +2x |
- "0.9.4", "forest_grob()",+ tbl_widths <- formatters::propose_column_widths(mat_form) |
| 496 | -1x | +920 | +2x |
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
+ |
+
| 921 | +2x | +
+ if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ |
+ ||
| 922 | +2x | +
+ if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1]) |
||
| 497 | +923 |
- )+ } |
||
| 498 | +924 | |||
| 499 | -1x | +|||
| 925 | +
- nr <- nrow(tbl)+ # Widths for row name, cols, forest. |
|||
| 500 | -1x | -
- if (is.null(vline)) {
- |
- ||
| 501 | -! | +926 | +2x |
- checkmate::assert_true(is.null(forest_header))+ widths <- grid::unit.c( |
| 502 | -+ | |||
| 927 | +2x |
- } else {
+ width_row_names + gap_column, |
||
| 503 | -1x | +928 | +2x |
- checkmate::assert_number(vline)+ width_columns + gap_column, |
| 504 | -1x | +929 | +2x |
- checkmate::assert_character(forest_header, len = 2, null.ok = TRUE)+ width_forest |
| 505 | +930 |
- }+ ) |
||
| 506 | +931 | |||
| 507 | -1x | +932 | +2x |
- checkmate::assert_numeric(x, len = nr)+ n_lines_per_row <- apply( |
| 508 | -1x | +933 | +2x |
- checkmate::assert_numeric(lower, len = nr)+ X = mat_form$strings, |
| 509 | -1x | +934 | +2x |
- checkmate::assert_numeric(upper, len = nr)+ MARGIN = 1, |
| 510 | -1x | +935 | +2x |
- checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE)+ FUN = function(row) {
|
| 511 | -1x | -
- checkmate::assert_character(col)- |
- ||
| 512 | -+ | 936 | +10x |
-
+ tmp <- vapply( |
| 513 | -1x | +937 | +10x |
- if (is.null(symbol_size)) {
+ gregexpr("\n", row, fixed = TRUE),
|
| 514 | -! | +|||
| 938 | +10x |
- symbol_size <- rep(1, nr)+ attr, numeric(1), |
||
| 515 | -+ | |||
| 939 | +10x |
- }+ "match.length" |
||
| 516 | -+ | |||
| 940 | +10x |
-
+ ) + 1 |
||
| 517 | -1x | +941 | +10x |
- if (is.null(xlim)) {
+ max(c(tmp, 1)) |
| 518 | -! | +|||
| 942 | +
- r <- range(c(x, lower, upper), na.rm = TRUE)+ } |
|||
| 519 | -! | +|||
| 943 | +
- xlim <- r + c(-0.05, 0.05) * diff(r)+ ) |
|||
| 520 | +944 |
- }+ + |
+ ||
| 945 | +2x | +
+ i_header <- seq_len(nr_h) |
||
| 521 | +946 | |||
| 522 | -1x | +947 | +2x |
- if (logx) {
+ height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines") |
| 523 | -1x | +948 | +2x |
- if (is.null(x_at)) {
+ height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines") |
| 524 | -! | +|||
| 949 | +
- x_at <- pretty(log(stats::na.omit(c(x, lower, upper))))+ |
|||
| 525 | -! | +|||
| 950 | +2x |
- x_labels <- exp(x_at)+ height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines") |
||
| 526 | -+ | |||
| 951 | +2x |
- } else {
+ height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines") |
||
| 527 | -1x | +|||
| 952 | +
- x_labels <- x_at+ |
|||
| 528 | -1x | +953 | +2x |
- x_at <- log(x_at)+ nc_g <- nc + 2 # number of columns incl. row names and forest |
| 529 | +954 |
- }+ |
||
| 530 | -1x | +955 | +2x |
- xlim <- log(xlim)+ vp_tbl <- grid::vpTree( |
| 531 | -1x | +956 | +2x |
- x <- log(x)+ parent = grid::viewport( |
| 532 | -1x | +957 | +2x |
- lower <- log(lower)+ name = "vp_table_layout", |
| 533 | -1x | +958 | +2x |
- upper <- log(upper)+ layout = grid::grid.layout( |
| 534 | -1x | +959 | +2x |
- if (!is.null(vline)) {
+ nrow = 3, ncol = 1, |
| 535 | -1x | +960 | +2x |
- vline <- log(vline)+ heights = grid::unit.c(height_header, gap_header, height_body) |
| 536 | +961 |
- }+ ) |
||
| 537 | +962 |
- } else {
+ ), |
||
| 538 | -! | +|||
| 963 | +2x |
- x_labels <- TRUE+ children = grid::vpList( |
||
| 539 | -+ | |||
| 964 | +2x |
- }+ vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"), |
||
| 540 | -+ | |||
| 965 | +2x |
-
+ vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"), |
||
| 541 | -1x | +966 | +2x |
- data_forest_vp <- grid::dataViewport(xlim, c(0, 1))+ grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1) |
| 542 | +967 |
-
+ ) |
||
| 543 | +968 |
- # Get table content as matrix form.+ ) |
||
| 544 | -1x | +969 | +2x |
- mf <- matrix_form(tbl)+ vp_tbl |
| 545 | +970 |
-
+ } |
||
| 546 | +971 |
- # Use `rtables` indent_string eventually.+ |
||
| 547 | -1x | +|||
| 972 | +
- mf$strings[, 1] <- paste0(+ #' Viewport forest plot: table part |
|||
| 548 | -1x | +|||
| 973 | +
- strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
+ #' |
|||
| 549 | -1x | +|||
| 974 | +
- mf$strings[, 1]+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 550 | +975 |
- )+ #' |
||
| 551 | +976 |
-
+ #' Prepares a viewport for the table included in the forest plot. |
||
| 552 | -1x | +|||
| 977 | +
- n_header <- attr(mf, "nrow_header")+ #' |
|||
| 553 | +978 |
-
+ #' @noRd |
||
| 554 | -! | +|||
| 979 | +
- if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
+ #' @keywords internal |
|||
| 555 | +980 |
-
+ vp_forest_table_part <- function(nrow, |
||
| 556 | +981 |
- # Pre-process the data to be used in lapply and cell_in_rows.+ ncol, |
||
| 557 | -1x | +|||
| 982 | +
- to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
+ l_row, |
|||
| 558 | -1x | +|||
| 983 | +
- underline_colspan = FALSE) {
+ l_col, |
|||
| 559 | -2x | +|||
| 984 | +
- part <- match.arg(part)+ widths,+ |
+ |||
| 985 | ++ |
+ heights,+ |
+ ||
| 986 | ++ |
+ name) {
|
||
| 560 | -2x | +987 | +4x |
- if (part == "body") {
+ lifecycle::deprecate_warn( |
| 561 | -1x | +988 | +4x |
- mat_row_indices <- seq_len(nrow(tbl)) + n_header+ "0.9.4", "vp_forest_table_part()", |
| 562 | -1x | +989 | +4x |
- row_ind_offset <- -n_header+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 563 | +990 |
- } else {
+ ) |
||
| 564 | -1x | +|||
| 991 | +
- mat_row_indices <- seq_len(n_header)+ |
|||
| 565 | -1x | +992 | +4x |
- row_ind_offset <- 0+ grid::vpTree( |
| 566 | -+ | |||
| 993 | +4x |
- }+ grid::viewport( |
||
| 567 | -+ | |||
| 994 | +4x |
-
+ name = name, |
||
| 568 | -2x | +995 | +4x |
- lapply(mat_row_indices, function(i) {
+ layout.pos.row = l_row, |
| 569 | -5x | +996 | +4x |
- disp <- mf$display[i, -1]+ layout.pos.col = l_col, |
| 570 | -5x | +997 | +4x |
- list(+ layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)+ |
+
| 998 | ++ |
+ ), |
||
| 571 | -5x | +999 | +4x |
- row_name = mf$strings[i, 1],+ children = grid::vpList( |
| 572 | -5x | +1000 | +4x |
- cells = mf$strings[i, -1][disp],+ do.call( |
| 573 | -5x | +1001 | +4x |
- cell_spans = mf$spans[i, -1][disp],+ grid::vpList, |
| 574 | -5x | +1002 | +4x |
- row_index = i + row_ind_offset,+ lapply( |
| 575 | -5x | +1003 | +4x |
- underline_colspan = underline_colspan+ seq_len(nrow), function(i) {
|
| 576 | -+ | |||
| 1004 | +10x |
- )+ grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
|
||
| 577 | +1005 |
- })+ } |
||
| 578 | +1006 |
- }+ ) |
||
| 579 | +1007 |
-
+ ), |
||
| 580 | -1x | +1008 | +4x |
- args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
+ do.call( |
| 581 | -1x | +1009 | +4x |
- args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
+ grid::vpList, |
| 582 | -+ | |||
| 1010 | +4x |
-
+ apply( |
||
| 583 | -1x | +1011 | +4x |
- grid::gTree(+ expand.grid(seq_len(nrow), seq_len(ncol - 2)), |
| 584 | -1x | +1012 | +4x |
- name = name,+ 1, |
| 585 | -1x | +1013 | +4x |
- children = grid::gList(+ function(x) {
|
| 586 | -1x | +1014 | +35x |
- grid::gTree(+ i <- x[1] |
| 587 | -1x | +1015 | +35x |
- children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)),+ j <- x[2] |
| 588 | -1x | +1016 | +35x |
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
|
| 589 | +1017 |
- ),+ } |
||
| 590 | -1x | +|||
| 1018 | +
- grid::gTree(+ ) |
|||
| 591 | -1x | +|||
| 1019 | +
- children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)),+ ), |
|||
| 592 | -1x | +1020 | +4x |
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ do.call( |
| 593 | -+ | |||
| 1021 | +4x |
- ),+ grid::vpList, |
||
| 594 | -1x | +1022 | +4x |
- grid::linesGrob(+ lapply( |
| 595 | -1x | +1023 | +4x |
- grid::unit(c(0, 1), "npc"),+ seq_len(nrow), |
| 596 | -1x | +1024 | +4x |
- y = grid::unit(c(.5, .5), "npc"),+ function(i) {
|
| 597 | -1x | +1025 | +10x |
- vp = grid::vpPath("vp_table_layout", "vp_spacer")
+ grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
|
| 598 | +1026 |
- ),+ } |
||
| 599 | +1027 |
- # forest part+ ) |
||
| 600 | -1x | +|||
| 1028 | +
- if (is.null(vline)) {
+ ) |
|||
| 601 | -! | +|||
| 1029 | +
- NULL+ ) |
|||
| 602 | +1030 |
- } else {
+ ) |
||
| 603 | -1x | +|||
| 1031 | +
- grid::gTree(+ } |
|||
| 604 | -1x | +|||
| 1032 | +
- children = grid::gList(+ |
|||
| 605 | -1x | +|||
| 1033 | +
- grid::gTree(+ #' Forest rendering |
|||
| 606 | -1x | +|||
| 1034 | +
- children = grid::gList(+ #' |
|||
| 607 | +1035 |
- # this may overflow, to fix, look here+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 608 | +1036 |
- # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint+ #' |
||
| 609 | -1x | +|||
| 1037 | +
- grid::textGrob(+ #' Renders the forest grob. |
|||
| 610 | -1x | +|||
| 1038 | +
- forest_header[1],+ #' |
|||
| 611 | -1x | +|||
| 1039 | +
- x = grid::unit(vline, "native") - grid::unit(1, "lines"),+ #' @noRd |
|||
| 612 | -1x | +|||
| 1040 | +
- just = c("right", "center")
+ #' @keywords internal |
|||
| 613 | +1041 |
- ),+ grid.forest <- function(...) { # nolint
|
||
| 614 | -1x | +|||
| 1042 | +! |
- grid::textGrob(+ lifecycle::deprecate_warn( |
||
| 615 | -1x | +|||
| 1043 | +! |
- forest_header[2],+ "0.9.4", "grid.forest()", |
||
| 616 | -1x | +|||
| 1044 | +! |
- x = grid::unit(vline, "native") + grid::unit(1, "lines"),+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 617 | -1x | +|||
| 1045 | +
- just = c("left", "center")
+ ) |
|||
| 618 | +1046 |
- )+ + |
+ ||
| 1047 | +! | +
+ grid::grid.draw(forest_grob(...)) |
||
| 619 | +1048 |
- ),+ } |
||
| 620 | -1x | +
| 1 | +
- vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp)+ #' Helper functions for incidence rate |
|||
| 621 | +2 |
- )+ #' |
||
| 622 | +3 |
- ),+ #' @description `r lifecycle::badge("stable")`
|
||
| 623 | -1x | +|||
| 4 | +
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ #' |
|||
| 624 | +5 |
- )+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
||
| 625 | +6 |
- },+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
||
| 626 | -1x | +|||
| 7 | +
- grid::gTree(+ #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate. |
|||
| 627 | -1x | +|||
| 8 | +
- children = grid::gList(+ #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
|||
| 628 | -1x | +|||
| 9 | +
- grid::gTree(+ #' for confidence interval type. |
|||
| 629 | -1x | +|||
| 10 | +
- children = grid::gList(+ #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default) |
|||
| 630 | -1x | +|||
| 11 | +
- grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")),+ #' indicating time unit for data input. |
|||
| 631 | -1x | +|||
| 12 | +
- if (is.null(vline)) {
+ #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years). |
|||
| 632 | -! | +|||
| 13 | +
- NULL+ #' @param person_years (`numeric(1)`)\cr total person-years at risk. |
|||
| 633 | +14 |
- } else {
+ #' @param alpha (`numeric(1)`)\cr two-sided alpha-level for confidence interval. |
||
| 634 | -1x | +|||
| 15 | +
- grid::linesGrob(+ #' @param n_events (`integer(1)`)\cr number of events observed. |
|||
| 635 | -1x | +|||
| 16 | +
- x = grid::unit(rep(vline, 2), "native"),+ #' |
|||
| 636 | -1x | +|||
| 17 | +
- y = grid::unit(c(0, 1), "npc"),+ #' @return Estimated incidence rate, `rate`, and associated confidence interval, `rate_ci`. |
|||
| 637 | -1x | +|||
| 18 | +
- gp = grid::gpar(lwd = 2),+ #' |
|||
| 638 | -1x | +|||
| 19 | +
- vp = data_forest_vp+ #' @seealso [incidence_rate] |
|||
| 639 | +20 |
- )+ #' |
||
| 640 | +21 |
- },+ #' @name h_incidence_rate |
||
| 641 | -1x | +|||
| 22 | +
- grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp)+ NULL |
|||
| 642 | +23 |
- ),+ |
||
| 643 | -1x | +|||
| 24 | +
- vp = grid::viewport(layout.pos.col = ncol(tbl) + 2)+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|||
| 644 | +25 |
- )+ #' associated confidence interval. |
||
| 645 | +26 |
- ),+ #' |
||
| 646 | -1x | +|||
| 27 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ #' @keywords internal |
|||
| 647 | +28 |
- ),+ h_incidence_rate <- function(person_years, |
||
| 648 | -1x | +|||
| 29 | +
- grid::gTree(+ n_events, |
|||
| 649 | -1x | +|||
| 30 | +
- children = do.call(+ control = control_incidence_rate()) {
|
|||
| 650 | -1x | +31 | +18x |
- grid::gList,+ alpha <- 1 - control$conf_level |
| 651 | -1x | +32 | +18x |
- Map(+ est <- switch(control$conf_type, |
| 652 | -1x | +33 | +18x |
- function(xi, li, ui, row_index, size_i, col) {
+ normal = h_incidence_rate_normal(person_years, n_events, alpha), |
| 653 | -3x | +34 | +18x |
- forest_dot_line(+ normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha), |
| 654 | -3x | +35 | +18x |
- xi,+ exact = h_incidence_rate_exact(person_years, n_events, alpha), |
| 655 | -3x | +36 | +18x |
- li,+ byar = h_incidence_rate_byar(person_years, n_events, alpha) |
| 656 | -3x | +|||
| 37 | +
- ui,+ ) |
|||
| 657 | -3x | +|||
| 38 | +
- row_index,+ |
|||
| 658 | -3x | +39 | +18x |
- xlim,+ num_pt_year <- control$num_pt_year |
| 659 | -3x | +40 | +18x |
- symbol_size = size_i,+ list( |
| 660 | -3x | +41 | +18x |
- col = col,+ rate = est$rate * num_pt_year, |
| 661 | -3x | +42 | +18x |
- datavp = data_forest_vp+ rate_ci = est$rate_ci * num_pt_year |
| 662 | +43 |
- )+ ) |
||
| 663 | +44 |
- },+ } |
||
| 664 | -1x | +|||
| 45 | +
- x,+ |
|||
| 665 | -1x | +|||
| 46 | +
- lower,+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|||
| 666 | -1x | +|||
| 47 | +
- upper,+ #' associated confidence interval based on the normal approximation for the |
|||
| 667 | -1x | +|||
| 48 | +
- seq_along(x),+ #' incidence rate. Unit is one person-year. |
|||
| 668 | -1x | +|||
| 49 | +
- symbol_size,+ #' |
|||
| 669 | -1x | +|||
| 50 | +
- col,+ #' @examples |
|||
| 670 | -1x | +|||
| 51 | +
- USE.NAMES = FALSE+ #' h_incidence_rate_normal(200, 2) |
|||
| 671 | +52 |
- )+ #' |
||
| 672 | +53 |
- ),+ #' @export |
||
| 673 | -1x | +|||
| 54 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ h_incidence_rate_normal <- function(person_years, |
|||
| 674 | +55 |
- )+ n_events, |
||
| 675 | +56 |
- ),+ alpha = 0.05) {
|
||
| 676 | -1x | +57 | +14x |
- childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ checkmate::assert_number(person_years) |
| 677 | -1x | +58 | +14x |
- vp = vp,+ checkmate::assert_number(n_events) |
| 678 | -1x | +59 | +14x |
- gp = gp+ assert_proportion_value(alpha) |
| 679 | +60 |
- )+ + |
+ ||
| 61 | +14x | +
+ est <- n_events / person_years+ |
+ ||
| 62 | +14x | +
+ se <- sqrt(est / person_years)+ |
+ ||
| 63 | +14x | +
+ ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se |
||
| 680 | +64 | ++ | + + | +|
| 65 | +14x | +
+ list(rate = est, rate_ci = ci)+ |
+ ||
| 66 |
} |
|||
| 681 | +67 | |||
| 682 | +68 |
- cell_in_rows <- function(row_name,+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 683 | +69 |
- cells,+ #' associated confidence interval based on the normal approximation for the |
||
| 684 | +70 |
- cell_spans,+ #' logarithm of the incidence rate. Unit is one person-year. |
||
| 685 | +71 |
- row_index,+ #' |
||
| 686 | +72 |
- underline_colspan = FALSE) {
+ #' @examples |
||
| 687 | -5x | +|||
| 73 | +
- checkmate::assert_string(row_name)+ #' h_incidence_rate_normal_log(200, 2) |
|||
| 688 | -5x | +|||
| 74 | +
- checkmate::assert_character(cells, min.len = 1, any.missing = FALSE)+ #' |
|||
| 689 | -5x | +|||
| 75 | +
- checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE)+ #' @export |
|||
| 690 | -5x | +|||
| 76 | +
- checkmate::assert_number(row_index)+ h_incidence_rate_normal_log <- function(person_years, |
|||
| 691 | -5x | +|||
| 77 | +
- checkmate::assert_flag(underline_colspan)+ n_events, |
|||
| 692 | +78 |
-
+ alpha = 0.05) {
|
||
| 693 | -5x | +79 | +6x |
- vp_name_rn <- paste0("rowname-", row_index)
+ checkmate::assert_number(person_years) |
| 694 | -5x | +80 | +6x |
- g_rowname <- if (!is.null(row_name) && row_name != "") {
+ checkmate::assert_number(n_events) |
| 695 | -3x | +81 | +6x |
- grid::textGrob(+ assert_proportion_value(alpha) |
| 696 | -3x | +|||
| 82 | +
- name = vp_name_rn,+ |
|||
| 697 | -3x | +83 | +6x |
- label = row_name,+ rate_est <- n_events / person_years |
| 698 | -3x | +84 | +6x |
- x = grid::unit(0, "npc"),+ rate_se <- sqrt(rate_est / person_years) |
| 699 | -3x | +85 | +6x |
- just = c("left", "center"),
+ lrate_est <- log(rate_est) |
| 700 | -3x | +86 | +6x |
- vp = grid::vpPath(paste0("rowname-", row_index))
+ lrate_se <- rate_se / rate_est |
| 701 | -+ | |||
| 87 | +6x |
- )+ ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se) |
||
| 702 | +88 |
- } else {
+
|
||
| 703 | -2x | +89 | +6x |
- NULL+ list(rate = rate_est, rate_ci = ci) |
| 704 | +90 |
- }+ } |
||
| 705 | +91 | |||
| 706 | -5x | +|||
| 92 | +
- gl_cols <- if (!(length(cells) > 0)) {
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|||
| 707 | -! | +|||
| 93 | +
- list(NULL)+ #' associated exact confidence interval. Unit is one person-year. |
|||
| 708 | +94 |
- } else {
+ #' |
||
| 709 | -5x | +|||
| 95 | +
- j <- 1 # column index of cell+ #' @examples |
|||
| 710 | +96 |
-
+ #' h_incidence_rate_exact(200, 2) |
||
| 711 | -5x | +|||
| 97 | +
- lapply(seq_along(cells), function(k) {
+ #' |
|||
| 712 | -19x | +|||
| 98 | +
- cell_ascii <- cells[[k]]+ #' @export |
|||
| 713 | -19x | +|||
| 99 | +
- cs <- cell_spans[[k]]+ h_incidence_rate_exact <- function(person_years, |
|||
| 714 | +100 |
-
+ n_events,+ |
+ ||
| 101 | ++ |
+ alpha = 0.05) {
|
||
| 715 | -19x | +102 | +1x |
- if (is.na(cell_ascii) || is.null(cell_ascii)) {
+ checkmate::assert_number(person_years) |
| 716 | -! | +|||
| 103 | +1x |
- cell_ascii <- "NA"+ checkmate::assert_number(n_events) |
||
| 717 | -+ | |||
| 104 | +1x |
- }+ assert_proportion_value(alpha) |
||
| 718 | +105 | |||
| 719 | -19x | +106 | +1x |
- cell_name <- paste0("g-cell-", row_index, "-", j)
+ est <- n_events / person_years |
| 720 | -+ | |||
| 107 | +1x |
-
+ lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years) |
||
| 721 | -19x | +108 | +1x |
- cell_grobs <- if (identical(cell_ascii, "")) {
+ ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years) |
| 722 | -! | +|||
| 109 | +
- NULL+ + |
+ |||
| 110 | +1x | +
+ list(rate = est, rate_ci = c(lcl, ucl)) |
||
| 723 | +111 |
- } else {
+ } |
||
| 724 | -19x | +|||
| 112 | +
- if (cs == 1) {
+
|
|||
| 725 | -18x | +|||
| 113 | +
- grid::textGrob(+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|||
| 726 | -18x | +|||
| 114 | +
- label = cell_ascii,+ #' associated Byar's confidence interval. Unit is one person-year. |
|||
| 727 | -18x | +|||
| 115 | +
- name = cell_name,+ #' |
|||
| 728 | -18x | +|||
| 116 | +
- vp = grid::vpPath(paste0("cell-", row_index, "-", j))
+ #' @examples |
|||
| 729 | +117 |
- )+ #' h_incidence_rate_byar(200, 2) |
||
| 730 | +118 |
- } else {
+ #' |
||
| 731 | +119 |
- # +1 because of rowname+ #' @export |
||
| 732 | -1x | +|||
| 120 | +
- vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs))+ h_incidence_rate_byar <- function(person_years, |
|||
| 733 | +121 |
-
+ n_events, |
||
| 734 | -1x | +|||
| 122 | +
- lab <- grid::textGrob(+ alpha = 0.05) {
|
|||
| 735 | +123 | 1x |
- label = cell_ascii,+ checkmate::assert_number(person_years) |
|
| 736 | +124 | 1x |
- name = cell_name,+ checkmate::assert_number(n_events) |
|
| 737 | +125 | 1x |
- vp = vp_joined_cols- |
- |
| 738 | -- |
- )+ assert_proportion_value(alpha) |
||
| 739 | +126 | |||
| 740 | +127 | 1x |
- if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
+ est <- n_events / person_years |
|
| 741 | -! | +|||
| 128 | +1x |
- lab+ seg_1 <- n_events + 0.5 |
||
| 742 | -+ | |||
| 129 | +1x |
- } else {
+ seg_2 <- 1 - 1 / (9 * (n_events + 0.5)) |
||
| 743 | +130 | 1x |
- grid::gList(+ seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3 |
|
| 744 | +131 | 1x |
- lab,+ lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years |
|
| 745 | +132 | 1x |
- grid::linesGrob(+ ucl <- seg_1 * ((seg_2 + seg_3)^3) / person_years |
|
| 746 | -1x | +|||
| 133 | +
- x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")),+ |
|||
| 747 | +134 | 1x |
- y = grid::unit(c(0, 0), "npc"),+ list(rate = est, rate_ci = c(lcl, ucl)) |
|
| 748 | -1x | +|||
| 135 | +
- vp = vp_joined_cols+ } |
| 749 | +1 |
- )+ #' Incidence rate estimation |
||
| 750 | +2 |
- )+ #' |
||
| 751 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 752 | +4 |
- }+ #' |
||
| 753 | +5 |
- }+ #' The analyze function [estimate_incidence_rate()] creates a layout element to estimate an event rate adjusted for |
||
| 754 | -19x | +|||
| 6 | +
- j <<- j + cs+ #' person-years at risk, otherwise known as incidence rate. The primary analysis variable specified via `vars` is |
|||
| 755 | +7 |
-
+ #' the person-years at risk. In addition to this variable, the `n_events` variable for number of events observed (where |
||
| 756 | -19x | +|||
| 8 | +
- cell_grobs+ #' a value of 1 means an event was observed and 0 means that no event was observed) must also be specified. |
|||
| 757 | +9 |
- })+ #' |
||
| 758 | +10 |
- }+ #' @inheritParams argument_convention |
||
| 759 | +11 |
-
+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
||
| 760 | -5x | +|||
| 12 | +
- grid::gList(+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
|||
| 761 | -5x | +|||
| 13 | +
- g_rowname,+ #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate. |
|||
| 762 | -5x | +|||
| 14 | +
- do.call(grid::gList, gl_cols)+ #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
|||
| 763 | +15 |
- )+ #' for confidence interval type. |
||
| 764 | +16 |
- }+ #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 765 | +17 |
-
+ #' indicating time unit for data input. |
||
| 766 | +18 |
- #' Graphic object: forest dot line+ #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years). |
||
| 767 | +19 |
- #'+ #' @param n_events (`string`)\cr name of integer variable indicating whether an event has been observed (1) or not (0). |
||
| 768 | +20 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @param id_var (`string`)\cr name of variable used as patient identifier if `"n_unique"` is included in `.stats`. |
||
| 769 | +21 |
- #'+ #' Defaults to `"USUBJID"`. |
||
| 770 | +22 |
- #' Calculate the `grob` corresponding to the dot line within the forest plot.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 771 | +23 |
#' |
||
| 772 | +24 |
- #' @noRd+ #' Options are: ``r shQuote(get_stats("estimate_incidence_rate"))``
|
||
| 773 | +25 |
- #' @keywords internal+ #' @param summarize (`flag`)\cr whether the function should act as an analyze function (`summarize = FALSE`), or a |
||
| 774 | +26 |
- forest_dot_line <- function(x,+ #' summarize function (`summarize = TRUE`). Defaults to `FALSE`. |
||
| 775 | +27 |
- lower,+ #' @param label_fmt (`string`)\cr how labels should be formatted after a row split occurs if `summarize = TRUE`. The |
||
| 776 | +28 |
- upper,+ #' string should use `"%s"` to represent row split levels, and `"%.labels"` to represent labels supplied to the |
||
| 777 | +29 |
- row_index,+ #' `.labels` argument. Defaults to `"%s - %.labels"`. |
||
| 778 | +30 |
- xlim,+ #' |
||
| 779 | +31 |
- symbol_size = 1,+ #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate]. |
||
| 780 | +32 |
- col = "blue",+ #' |
||
| 781 | +33 |
- datavp) {
+ #' @examples |
||
| 782 | -3x | +|||
| 34 | +
- lifecycle::deprecate_warn(+ #' df <- data.frame( |
|||
| 783 | -3x | +|||
| 35 | +
- "0.9.4", "forest_dot_line()",+ #' USUBJID = as.character(seq(6)), |
|||
| 784 | -3x | +|||
| 36 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' CNSR = c(0, 1, 1, 0, 0, 0), |
|||
| 785 | +37 |
- )+ #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4), |
||
| 786 | +38 |
-
+ #' ARM = factor(c("A", "A", "A", "B", "B", "B")),
|
||
| 787 | -3x | +|||
| 39 | +
- ci <- c(lower, upper)+ #' STRATA1 = factor(c("X", "Y", "Y", "X", "X", "Y"))
|
|||
| 788 | -3x | +|||
| 40 | +
- if (any(!is.na(c(x, ci)))) {
+ #' ) |
|||
| 789 | +41 |
- # line+ #' df$n_events <- 1 - df$CNSR |
||
| 790 | -3x | +|||
| 42 | +
- y <- grid::unit(c(0.5, 0.5), "npc")+ #' |
|||
| 791 | +43 |
-
+ #' @name incidence_rate |
||
| 792 | -3x | +|||
| 44 | +
- g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
+ #' @order 1 |
|||
| 793 | +45 |
- # -+ NULL |
||
| 794 | -3x | +|||
| 46 | +
- if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
+
|
|||
| 795 | -3x | +|||
| 47 | +
- grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y)+ #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the |
|||
| 796 | -! | +|||
| 48 | +
- } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
+ #' associated confidence interval. |
|||
| 797 | +49 |
- # <->+ #' |
||
| 798 | -! | +|||
| 50 | +
- grid::linesGrob(+ #' @return |
|||
| 799 | -! | +|||
| 51 | +
- x = grid::unit(xlim, "native"),+ #' * `s_incidence_rate()` returns the following statistics: |
|||
| 800 | -! | +|||
| 52 | +
- y = y,+ #' - `person_years`: Total person-years at risk. |
|||
| 801 | -! | +|||
| 53 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both")+ #' - `n_events`: Total number of events observed. |
|||
| 802 | +54 |
- )+ #' - `rate`: Estimated incidence rate. |
||
| 803 | -! | +|||
| 55 | +
- } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
+ #' - `rate_ci`: Confidence interval for the incidence rate. |
|||
| 804 | +56 |
- # <-+ #' - `n_unique`: Total number of patients with at least one event observed. |
||
| 805 | -! | +|||
| 57 | +
- grid::linesGrob(+ #' - `n_rate`: Total number of events observed & estimated incidence rate. |
|||
| 806 | -! | +|||
| 58 | +
- x = grid::unit(c(xlim[1], ci[2]), "native"),+ #' |
|||
| 807 | -! | +|||
| 59 | +
- y = y,+ #' @keywords internal |
|||
| 808 | -! | +|||
| 60 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first")+ s_incidence_rate <- function(df, |
|||
| 809 | +61 |
- )+ .var, |
||
| 810 | -! | +|||
| 62 | +
- } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
+ n_events, |
|||
| 811 | +63 |
- # ->+ is_event = lifecycle::deprecated(), |
||
| 812 | -! | +|||
| 64 | +
- grid::linesGrob(+ id_var = "USUBJID", |
|||
| 813 | -! | +|||
| 65 | +
- x = grid::unit(c(ci[1], xlim[2]), "native"),+ control = control_incidence_rate()) {
+ |
+ |||
| 66 | +17x | +
+ if (lifecycle::is_present(is_event)) {
|
||
| 814 | +67 | ! |
- y = y,+ checkmate::assert_string(is_event) |
|
| 815 | +68 | ! |
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last")+ lifecycle::deprecate_warn( |
|
| 816 | -+ | |||
| 69 | +! |
- )+ "0.9.6", "s_incidence_rate(is_event)", "s_incidence_rate(n_events)" |
||
| 817 | +70 |
- }+ ) |
||
| 818 | -+ | |||
| 71 | +! |
- } else {
+ n_events <- is_event |
||
| 819 | +72 | ! |
- NULL+ df[[n_events]] <- as.numeric(df[[is_event]]) |
|
| 820 | +73 |
- }+ } |
||
| 821 | +74 | |||
| 822 | -3x | +75 | +17x |
- g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
+ assert_df_with_variables(df, list(tte = .var, n_events = n_events)) |
| 823 | -3x | +76 | +17x |
- grid::circleGrob(+ checkmate::assert_string(.var) |
| 824 | -3x | +77 | +17x |
- x = grid::unit(x, "native"),+ checkmate::assert_string(n_events) |
| 825 | -3x | +78 | +17x |
- y = y,+ checkmate::assert_string(id_var) |
| 826 | -3x | +79 | +17x |
- r = grid::unit(1 / 3.5 * symbol_size, "lines"),+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE) |
| 827 | -3x | +80 | +17x |
- name = "point"+ checkmate::assert_integerish(df[[n_events]], any.missing = FALSE) |
| 828 | +81 |
- )+ |
||
| 829 | -+ | |||
| 82 | +17x |
- } else {
+ n_unique <- n_available(unique(df[[id_var]][df[[n_events]] == 1])) |
||
| 830 | -! | +|||
| 83 | +17x |
- NULL+ input_time_unit <- control$input_time_unit |
||
| 831 | -+ | |||
| 84 | +17x |
- }+ num_pt_year <- control$num_pt_year |
||
| 832 | -+ | |||
| 85 | +17x |
-
+ conf_level <- control$conf_level |
||
| 833 | -3x | +86 | +17x |
- grid::gTree(+ person_years <- sum(df[[.var]], na.rm = TRUE) * ( |
| 834 | -3x | +87 | +17x |
- children = grid::gList(+ 1 * (input_time_unit == "year") + |
| 835 | -3x | +88 | +17x |
- grid::gTree(+ 1 / 12 * (input_time_unit == "month") + |
| 836 | -3x | +89 | +17x |
- children = grid::gList(+ 1 / 52.14 * (input_time_unit == "week") + |
| 837 | -3x | +90 | +17x |
- grid::gList(+ 1 / 365.24 * (input_time_unit == "day") |
| 838 | -3x | +|||
| 91 | +
- g_line,+ ) |
|||
| 839 | -3x | +92 | +17x |
- g_circle+ n_events <- sum(df[[n_events]], na.rm = TRUE) |
| 840 | +93 |
- )+ |
||
| 841 | -+ | |||
| 94 | +17x |
- ),+ result <- h_incidence_rate( |
||
| 842 | -3x | +95 | +17x |
- vp = datavp,+ person_years, |
| 843 | -3x | +96 | +17x |
- gp = grid::gpar(col = col, fill = col)+ n_events, |
| 844 | -+ | |||
| 97 | +17x |
- )+ control |
||
| 845 | +98 |
- ),+ ) |
||
| 846 | -3x | +99 | +17x |
- vp = grid::vpPath(paste0("forest-", row_index))
+ list( |
| 847 | -+ | |||
| 100 | +17x |
- )+ person_years = formatters::with_label(person_years, "Total patient-years at risk"), |
||
| 848 | -+ | |||
| 101 | +17x |
- } else {
+ n_events = formatters::with_label(n_events, "Number of adverse events observed"), |
||
| 849 | -! | +|||
| 102 | +17x |
- NULL+ rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
|
||
| 850 | -+ | |||
| 103 | +17x |
- }+ rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)), |
||
| 851 | -+ | |||
| 104 | +17x |
- }+ n_unique = formatters::with_label(n_unique, "Total number of patients with at least one adverse event"), |
||
| 852 | -+ | |||
| 105 | +17x |
-
+ n_rate = formatters::with_label( |
||
| 853 | -+ | |||
| 106 | +17x |
- #' Create a viewport tree for the forest plot+ c(n_events, result$rate), |
||
| 854 | -+ | |||
| 107 | +17x |
- #'+ paste("Number of adverse events observed (AE rate per", num_pt_year, "patient-years)")
|
||
| 855 | +108 |
- #' @description `r lifecycle::badge("deprecated")`
+ ) |
||
| 856 | +109 |
- #'+ ) |
||
| 857 | +110 |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ } |
||
| 858 | +111 |
- #' @param width_row_names (`grid::unit`)\cr width of row names.+ |
||
| 859 | +112 |
- #' @param width_columns (`grid::unit`)\cr width of column spans.+ #' @describeIn incidence_rate Formatted analysis function which is used as `afun` in `estimate_incidence_rate()`. |
||
| 860 | +113 |
- #' @param width_forest (`grid::unit`)\cr width of the forest plot.+ #' |
||
| 861 | +114 |
- #' @param gap_column (`grid::unit`)\cr gap width between the columns.+ #' @return |
||
| 862 | +115 |
- #' @param gap_header (`grid::unit`)\cr gap width between the header.+ #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 863 | +116 |
- #' @param mat_form (`MatrixPrintForm`)\cr matrix print form of the table.+ #' |
||
| 864 | +117 |
- #'+ #' @examples |
||
| 865 | +118 |
- #' @return A viewport tree.+ #' a_incidence_rate( |
||
| 866 | +119 |
- #'+ #' df, |
||
| 867 | +120 |
- #' @examples+ #' .var = "AVAL", |
||
| 868 | +121 |
- #' library(grid)+ #' .df_row = df, |
||
| 869 | +122 |
- #'+ #' n_events = "n_events" |
||
| 870 | +123 |
- #' tbl <- rtable(+ #' ) |
||
| 871 | +124 |
- #' header = rheader(+ #' |
||
| 872 | +125 |
- #' rrow("", "E", rcell("CI", colspan = 2)),
+ #' @export |
||
| 873 | +126 |
- #' rrow("", "A", "B", "C")
+ a_incidence_rate <- function(df, |
||
| 874 | +127 |
- #' ),+ labelstr = "", |
||
| 875 | -- |
- #' rrow("row 1", 1, 0.8, 1.1),
- |
- ||
| 876 | -- |
- #' rrow("row 2", 1.4, 0.8, 1.6),
- |
- ||
| 877 | +128 |
- #' rrow("row 3", 1.2, 0.8, 1.2)
+ .var, |
||
| 878 | +129 |
- #' )+ .df_row, |
||
| 879 | +130 |
- #'+ n_events, |
||
| 880 | +131 |
- #' \donttest{
+ id_var = "USUBJID", |
||
| 881 | +132 |
- #' v <- forest_viewport(tbl)+ control = control_incidence_rate(), |
||
| 882 | +133 |
- #'+ .stats = NULL, |
||
| 883 | +134 |
- #' grid::grid.newpage()+ .formats = c( |
||
| 884 | +135 |
- #' showViewport(v)+ "person_years" = "xx.x", |
||
| 885 | +136 |
- #' }+ "n_events" = "xx", |
||
| 886 | +137 |
- #'+ "rate" = "xx.xx", |
||
| 887 | +138 |
- #' @export+ "rate_ci" = "(xx.xx, xx.xx)", |
||
| 888 | +139 |
- forest_viewport <- function(tbl,+ "n_unique" = "xx", |
||
| 889 | +140 |
- width_row_names = NULL,+ "n_rate" = "xx (xx.x)" |
||
| 890 | +141 |
- width_columns = NULL,+ ), |
||
| 891 | +142 |
- width_forest = grid::unit(1, "null"),+ .labels = NULL, |
||
| 892 | +143 |
- gap_column = grid::unit(1, "lines"),+ .indent_mods = NULL, |
||
| 893 | +144 |
- gap_header = grid::unit(1, "lines"),+ na_str = default_na_str(), |
||
| 894 | +145 |
- mat_form = NULL) {
- |
- ||
| 895 | -2x | -
- lifecycle::deprecate_warn(- |
- ||
| 896 | -2x | -
- "0.9.4",- |
- ||
| 897 | -2x | -
- "forest_viewport()",+ label_fmt = "%s - %.labels") {
|
||
| 898 | -2x | -
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."- |
- ||
| 899 | -+ | 146 | +16x |
- )+ checkmate::assert_string(label_fmt) |
| 900 | +147 | |||
| 901 | -2x | -
- checkmate::assert_class(tbl, "VTableTree")- |
- ||
| 902 | -2x | +148 | +16x |
- checkmate::assert_true(grid::is.unit(width_forest))+ x_stats <- s_incidence_rate( |
| 903 | -2x | -
- if (!is.null(width_row_names)) {
- |
- ||
| 904 | -! | +149 | +16x |
- checkmate::assert_true(grid::is.unit(width_row_names))+ df = df, .var = .var, n_events = n_events, id_var = id_var, control = control |
| 905 | +150 |
- }+ ) |
||
| 906 | -2x | +151 | +16x |
- if (!is.null(width_columns)) {
+ if (is.null(unlist(x_stats))) {
|
| 907 | +152 | ! |
- checkmate::assert_true(grid::is.unit(width_columns))+ return(NULL) |
|
| 908 | +153 |
} |
||
| 909 | -- | - - | -||
| 910 | -2x | -
- if (is.null(mat_form)) mat_form <- matrix_form(tbl)- |
- ||
| 911 | +154 | |||
| 912 | -2x | -
- mat_form$strings[!mat_form$display] <- ""- |
- ||
| 913 | +155 | - - | -||
| 914 | -2x | -
- nr <- nrow(tbl)- |
- ||
| 915 | -2x | -
- nc <- ncol(tbl)+ # Fill in with defaults |
||
| 916 | -2x | -
- nr_h <- attr(mat_form, "nrow_header")- |
- ||
| 917 | -+ | 156 | +16x |
-
+ formats_def <- formals()$.formats %>% eval() |
| 918 | -2x | +157 | +16x |
- if (is.null(width_row_names) || is.null(width_columns)) {
+ .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))] |
| 919 | -2x | +158 | +16x |
- tbl_widths <- formatters::propose_column_widths(mat_form)+ labels_def <- sapply(x_stats, \(x) attributes(x)$label) |
| 920 | -2x | +159 | +16x |
- strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
+ .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))] |
| 921 | -2x | +160 | +16x |
- if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ if (nzchar(labelstr) > 0) {
|
| 922 | -2x | +161 | +8x |
- if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1])+ .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
|
| 923 | +162 |
} |
||
| 924 | +163 | |||
| 925 | +164 |
- # Widths for row name, cols, forest.+ # Fill in with formatting defaults if needed |
||
| 926 | -2x | +165 | +16x |
- widths <- grid::unit.c(+ .stats <- get_stats("estimate_incidence_rate", stats_in = .stats)
|
| 927 | -2x | +166 | +16x |
- width_row_names + gap_column,+ .formats <- get_formats_from_stats(.stats, .formats) |
| 928 | -2x | +167 | +16x |
- width_columns + gap_column,+ .labels <- get_labels_from_stats(.stats, .labels) |
| 929 | -2x | -
- width_forest- |
- ||
| 930 | -+ | 168 | +16x |
- )+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
| 931 | +169 | |||
| 932 | -2x | -
- n_lines_per_row <- apply(- |
- ||
| 933 | -2x | -
- X = mat_form$strings,- |
- ||
| 934 | -2x | +170 | +16x |
- MARGIN = 1,+ x_stats <- x_stats[.stats] |
| 935 | -2x | +|||
| 171 | +
- FUN = function(row) {
+
|
|||
| 936 | -10x | +172 | +16x |
- tmp <- vapply(+ in_rows( |
| 937 | -10x | +173 | +16x |
- gregexpr("\n", row, fixed = TRUE),
+ .list = x_stats, |
| 938 | -10x | +174 | +16x |
- attr, numeric(1),+ .formats = .formats, |
| 939 | -10x | +175 | +16x |
- "match.length"+ .labels = .labels, |
| 940 | -10x | +176 | +16x |
- ) + 1+ .indent_mods = .indent_mods, |
| 941 | -10x | +177 | +16x |
- max(c(tmp, 1))+ .format_na_strs = na_str |
| 942 | +178 |
- }+ ) |
||
| 943 | +179 |
- )+ } |
||
| 944 | +180 | |||
| 945 | -2x | -
- i_header <- seq_len(nr_h)- |
- ||
| 946 | +181 | - - | -||
| 947 | -2x | -
- height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines")- |
- ||
| 948 | -2x | -
- height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines")+ #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments |
||
| 949 | +182 | - - | -||
| 950 | -2x | -
- height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines")- |
- ||
| 951 | -2x | -
- height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines")+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 952 | +183 |
-
+ #' |
||
| 953 | -2x | +|||
| 184 | +
- nc_g <- nc + 2 # number of columns incl. row names and forest+ #' @return |
|||
| 954 | +185 |
-
+ #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions, |
||
| 955 | -2x | +|||
| 186 | +
- vp_tbl <- grid::vpTree(+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 956 | -2x | +|||
| 187 | +
- parent = grid::viewport(+ #' the statistics from `s_incidence_rate()` to the table layout. |
|||
| 957 | -2x | +|||
| 188 | +
- name = "vp_table_layout",+ #' |
|||
| 958 | -2x | +|||
| 189 | +
- layout = grid::grid.layout(+ #' @examples |
|||
| 959 | -2x | +|||
| 190 | +
- nrow = 3, ncol = 1,+ #' basic_table(show_colcounts = TRUE) %>% |
|||
| 960 | -2x | +|||
| 191 | +
- heights = grid::unit.c(height_header, gap_header, height_body)+ #' split_cols_by("ARM") %>%
|
|||
| 961 | +192 |
- )+ #' estimate_incidence_rate( |
||
| 962 | +193 |
- ),+ #' vars = "AVAL", |
||
| 963 | -2x | +|||
| 194 | +
- children = grid::vpList(+ #' n_events = "n_events", |
|||
| 964 | -2x | +|||
| 195 | +
- vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),+ #' control = control_incidence_rate( |
|||
| 965 | -2x | +|||
| 196 | +
- vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),+ #' input_time_unit = "month", |
|||
| 966 | -2x | +|||
| 197 | +
- grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1)+ #' num_pt_year = 100 |
|||
| 967 | +198 |
- )+ #' ) |
||
| 968 | +199 |
- )+ #' ) %>% |
||
| 969 | -2x | +|||
| 200 | +
- vp_tbl+ #' build_table(df) |
|||
| 970 | +201 |
- }+ #' |
||
| 971 | +202 |
-
+ #' # summarize = TRUE |
||
| 972 | +203 |
- #' Viewport forest plot: table part+ #' basic_table(show_colcounts = TRUE) %>% |
||
| 973 | +204 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 974 | +205 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' split_rows_by("STRATA1", child_labels = "visible") %>%
|
||
| 975 | +206 |
- #'+ #' estimate_incidence_rate( |
||
| 976 | +207 |
- #' Prepares a viewport for the table included in the forest plot.+ #' vars = "AVAL", |
||
| 977 | +208 |
- #'+ #' n_events = "n_events", |
||
| 978 | +209 |
- #' @noRd+ #' .stats = c("n_unique", "n_rate"),
|
||
| 979 | +210 |
- #' @keywords internal+ #' summarize = TRUE, |
||
| 980 | +211 |
- vp_forest_table_part <- function(nrow,+ #' label_fmt = "%.labels" |
||
| 981 | +212 |
- ncol,+ #' ) %>% |
||
| 982 | +213 |
- l_row,+ #' build_table(df) |
||
| 983 | +214 |
- l_col,+ #' |
||
| 984 | +215 |
- widths,+ #' @export |
||
| 985 | +216 |
- heights,+ #' @order 2 |
||
| 986 | +217 |
- name) {
+ estimate_incidence_rate <- function(lyt, |
||
| 987 | -4x | +|||
| 218 | +
- lifecycle::deprecate_warn(+ vars, |
|||
| 988 | -4x | +|||
| 219 | +
- "0.9.4", "vp_forest_table_part()",+ n_events, |
|||
| 989 | -4x | +|||
| 220 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ id_var = "USUBJID", |
|||
| 990 | +221 |
- )+ control = control_incidence_rate(), |
||
| 991 | +222 |
-
+ na_str = default_na_str(), |
||
| 992 | -4x | +|||
| 223 | +
- grid::vpTree(+ nested = TRUE, |
|||
| 993 | -4x | +|||
| 224 | +
- grid::viewport(+ summarize = FALSE, |
|||
| 994 | -4x | +|||
| 225 | +
- name = name,+ label_fmt = "%s - %.labels", |
|||
| 995 | -4x | +|||
| 226 | +
- layout.pos.row = l_row,+ ..., |
|||
| 996 | -4x | +|||
| 227 | +
- layout.pos.col = l_col,+ show_labels = "hidden", |
|||
| 997 | -4x | +|||
| 228 | +
- layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)+ table_names = vars, |
|||
| 998 | +229 |
- ),+ .stats = c("person_years", "n_events", "rate", "rate_ci"),
|
||
| 999 | -4x | +|||
| 230 | +
- children = grid::vpList(+ .formats = NULL, |
|||
| 1000 | -4x | +|||
| 231 | +
- do.call(+ .labels = NULL, |
|||
| 1001 | -4x | +|||
| 232 | +
- grid::vpList,+ .indent_mods = NULL) {
|
|||
| 1002 | -4x | +233 | +5x |
- lapply(+ extra_args <- c( |
| 1003 | -4x | +234 | +5x |
- seq_len(nrow), function(i) {
+ list(.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str), |
| 1004 | -10x | +235 | +5x |
- grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
+ list(n_events = n_events, id_var = id_var, control = control, label_fmt = label_fmt, ...) |
| 1005 | +236 |
- }+ ) |
||
| 1006 | +237 |
- )+ |
||
| 1007 | -+ | |||
| 238 | +5x |
- ),+ if (!summarize) {
|
||
| 1008 | -4x | +239 | +3x |
- do.call(+ analyze( |
| 1009 | -4x | +240 | +3x |
- grid::vpList,+ lyt, |
| 1010 | -4x | +241 | +3x |
- apply(+ vars, |
| 1011 | -4x | +242 | +3x |
- expand.grid(seq_len(nrow), seq_len(ncol - 2)),+ show_labels = show_labels, |
| 1012 | -4x | +243 | +3x |
- 1,+ table_names = table_names, |
| 1013 | -4x | +244 | +3x |
- function(x) {
+ afun = a_incidence_rate, |
| 1014 | -35x | +245 | +3x |
- i <- x[1]+ na_str = na_str, |
| 1015 | -35x | +246 | +3x |
- j <- x[2]+ nested = nested, |
| 1016 | -35x | +247 | +3x |
- grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
+ extra_args = extra_args |
| 1017 | +248 |
- }+ ) |
||
| 1018 | +249 |
- )+ } else {
|
||
| 1019 | -+ | |||
| 250 | +2x |
- ),+ summarize_row_groups( |
||
| 1020 | -4x | +251 | +2x |
- do.call(+ lyt, |
| 1021 | -4x | +252 | +2x |
- grid::vpList,+ vars, |
| 1022 | -4x | +253 | +2x |
- lapply(+ cfun = a_incidence_rate, |
| 1023 | -4x | +254 | +2x |
- seq_len(nrow),+ na_str = na_str, |
| 1024 | -4x | +255 | +2x |
- function(i) {
+ extra_args = extra_args |
| 1025 | -10x | +|||
| 256 | +
- grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
+ ) |
|||
| 1026 | +257 |
- }+ } |
||
| 1027 | +258 |
- )+ } |
| 1028 | +1 |
- )+ #' Count number of patients with missed doses by thresholds |
|
| 1029 | +2 |
- )+ #' |
|
| 1030 | +3 |
- )+ #' @description `r lifecycle::badge("stable")`
|
|
| 1031 | +4 |
- }+ #' |
|
| 1032 | +5 |
-
+ #' The analyze function creates a layout element to calculate cumulative counts of patients with number of missed |
|
| 1033 | +6 |
- #' Forest rendering+ #' doses at least equal to user-specified threshold values. |
|
| 1034 | +7 |
#' |
|
| 1035 | +8 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' This function analyzes numeric variable `vars`, a variable with numbers of missed doses, |
|
| 1036 | +9 |
- #'+ #' against the threshold values supplied to the `thresholds` argument as a numeric vector. This function |
|
| 1037 | +10 |
- #' Renders the forest grob.+ #' assumes that every row of the given data frame corresponds to a unique patient. |
|
| 1038 | +11 |
#' |
|
| 1039 | +12 |
- #' @noRd+ #' @inheritParams s_count_cumulative |
|
| 1040 | +13 |
- #' @keywords internal+ #' @inheritParams argument_convention |
|
| 1041 | +14 |
- grid.forest <- function(...) { # nolint
- |
- |
| 1042 | -! | -
- lifecycle::deprecate_warn(- |
- |
| 1043 | -! | -
- "0.9.4", "grid.forest()",+ #' @param thresholds (`numeric`)\cr minimum number of missed doses the patients had. |
|
| 1044 | -! | +||
| 15 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 1045 | +16 |
- )+ #' |
|
| 1046 | +17 |
-
+ #' Options are: ``r shQuote(get_stats("count_missed_doses"))``
|
|
| 1047 | -! | +||
| 18 | +
- grid::grid.draw(forest_grob(...))+ #' |
||
| 1048 | +19 |
- }+ #' @seealso |
| 1 | +20 |
- #' Proportion estimation+ #' * Relevant description function [d_count_missed_doses()] which generates labels for [count_missed_doses()]. |
|
| 2 | +21 |
- #'+ #' * Similar analyze function [count_cumulative()] which more generally counts cumulative values and has more |
|
| 3 | +22 |
- #' @description `r lifecycle::badge("stable")`
+ #' options for threshold handling, but uses different labels. |
|
| 4 | +23 |
#' |
|
| 5 | +24 |
- #' The analyze function [estimate_proportion()] creates a layout element to estimate the proportion of responders+ #' @name count_missed_doses |
|
| 6 | +25 |
- #' within a studied population. The primary analysis variable, `vars`, indicates whether a response has occurred for+ #' @order 1 |
|
| 7 | +26 |
- #' each record. See the `method` parameter for options of methods to use when constructing the confidence interval of+ NULL |
|
| 8 | +27 |
- #' the proportion. Additionally, a stratification variable can be supplied via the `strata` element of the `variables`+ |
|
| 9 | +28 |
- #' argument.+ #' @describeIn count_missed_doses Statistics function to count non-missing values. |
|
| 10 | +29 |
#' |
|
| 11 | +30 |
- #' @inheritParams prop_strat_wilson+ #' @return |
|
| 12 | +31 |
- #' @inheritParams argument_convention+ #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`. |
|
| 13 | +32 |
- #' @param method (`string`)\cr the method used to construct the confidence interval+ #' |
|
| 14 | +33 |
- #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,+ #' @keywords internal |
|
| 15 | +34 |
- #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.+ s_count_nonmissing <- function(x) {
|
|
| 16 | -+ | ||
| 35 | +9x |
- #' @param long (`flag`)\cr whether a long description is required.+ list(n = n_available(x)) |
|
| 17 | +36 |
- #' @param .stats (`character`)\cr statistics to select for the table.- |
- |
| 18 | -- |
- #'- |
- |
| 19 | -- |
- #' Options are: ``r shQuote(get_stats("estimate_proportion"))``
- |
- |
| 20 | -- |
- #'- |
- |
| 21 | -- |
- #' @seealso [h_proportions]- |
- |
| 22 | -- |
- #'- |
- |
| 23 | -- |
- #' @name estimate_proportion- |
- |
| 24 | -- |
- #' @order 1- |
- |
| 25 | -- |
- NULL- |
- |
| 26 | -- | - - | -|
| 27 | -- |
- #' @describeIn estimate_proportion Statistics function estimating a- |
- |
| 28 | -- |
- #' proportion along with its confidence interval.- |
- |
| 29 | -- |
- #'- |
- |
| 30 | -- |
- #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,- |
- |
| 31 | -- |
- #' it indicates whether each subject is a responder or not. `TRUE` represents- |
- |
| 32 | -- |
- #' a successful outcome. If a `data.frame` is provided, also the `strata` variable- |
- |
| 33 | -- |
- #' names must be provided in `variables` as a list element with the strata strings.- |
- |
| 34 | -- |
- #' In the case of `data.frame`, the logical vector of responses must be indicated as a- |
- |
| 35 | -- |
- #' variable name in `.var`.- |
- |
| 36 | -- |
- #'+ } |
|
| 37 |
- #' @return+ |
||
| 38 |
- #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a+ #' Description function that calculates labels for `s_count_missed_doses()` |
||
| 39 |
- #' given variable.+ #' |
||
| 40 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 41 |
- #' @examples+ #' |
||
| 42 |
- #' # Case with only logical vector.+ #' @inheritParams s_count_missed_doses |
||
| 43 |
- #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)+ #' |
||
| 44 |
- #' s_proportion(rsp_v)+ #' @return [d_count_missed_doses()] returns a named `character` vector with the labels. |
||
| 46 |
- #' # Example for Stratified Wilson CI+ #' @seealso [s_count_missed_doses()] |
||
| 47 |
- #' nex <- 100 # Number of example rows+ #' |
||
| 48 |
- #' dta <- data.frame(+ #' @export |
||
| 49 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ d_count_missed_doses <- function(thresholds) {
|
||
| 50 | -+ | 8x |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
|
| 51 |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ } |
||
| 52 |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+
|
||
| 53 |
- #' stringsAsFactors = TRUE+ #' @describeIn count_missed_doses Statistics function to count patients with missed doses. |
||
| 54 |
- #' )+ #' |
||
| 55 |
- #'+ #' @return |
||
| 56 |
- #' s_proportion(+ #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold. |
||
| 57 |
- #' df = dta,+ #' |
||
| 58 |
- #' .var = "rsp",+ #' @keywords internal |
||
| 59 |
- #' variables = list(strata = c("f1", "f2")),
+ s_count_missed_doses <- function(x, |
||
| 60 |
- #' conf_level = 0.90,+ thresholds, |
||
| 61 |
- #' method = "strat_wilson"+ .N_col, # nolint |
||
| 62 |
- #' )+ .N_row, # nolint |
||
| 63 |
- #'+ denom = c("N_col", "n", "N_row")) {
|
||
| 64 | -+ | 1x |
- #' @export+ stat <- s_count_cumulative( |
| 65 | -+ | 1x |
- s_proportion <- function(df,+ x = x, |
| 66 | -+ | 1x |
- .var,+ thresholds = thresholds, |
| 67 | -+ | 1x |
- conf_level = 0.95,+ lower_tail = FALSE, |
| 68 | -+ | 1x |
- method = c(+ include_eq = TRUE, |
| 69 | -+ | 1x |
- "waldcc", "wald", "clopper-pearson",+ .N_col = .N_col, |
| 70 | -+ | 1x |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ .N_row = .N_row, |
| 71 | -+ | 1x |
- "agresti-coull", "jeffreys"+ denom = denom |
| 72 |
- ),+ ) |
||
| 73 | -+ | 1x |
- weights = NULL,+ labels <- d_count_missed_doses(thresholds) |
| 74 | -+ | 1x |
- max_iterations = 50,+ for (i in seq_along(stat$count_fraction)) {
|
| 75 | -+ | 2x |
- variables = list(strata = NULL),+ stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i]) |
| 76 |
- long = FALSE) {
+ } |
||
| 77 | -167x | +1x |
- method <- match.arg(method)+ n_stat <- s_count_nonmissing(x) |
| 78 | -167x | +1x |
- checkmate::assert_flag(long)+ c(n_stat, stat) |
| 79 | -167x | +
- assert_proportion_value(conf_level)+ } |
|
| 81 | -167x | +
- if (!is.null(variables$strata)) {
+ #' @describeIn count_missed_doses Formatted analysis function which is used as `afun` |
|
| 82 |
- # Checks for strata+ #' in `count_missed_doses()`. |
||
| 83 | -! | +
- if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
+ #' |
|
| 84 | -! | +
- strata_colnames <- variables$strata+ #' @return |
|
| 85 | -! | +
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 86 | -! | +
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ #' |
|
| 87 | -! | +
- assert_df_with_variables(df, strata_vars)+ #' @keywords internal |
|
| 88 |
-
+ a_count_missed_doses <- make_afun( |
||
| 89 | -! | +
- strata <- interaction(df[strata_colnames])+ s_count_missed_doses, |
|
| 90 | -! | +
- strata <- as.factor(strata)+ .formats = c(n = "xx", count_fraction = format_count_fraction) |
|
| 91 |
-
+ ) |
||
| 92 |
- # Pushing down checks to prop_strat_wilson+ |
||
| 93 | -167x | +
- } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
+ #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments |
|
| 94 | -! | +
- stop("To use stratified methods you need to specify the strata variables.")
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 95 |
- }+ #' |
||
| 96 | -167x | +
- if (checkmate::test_atomic_vector(df)) {
+ #' @return |
|
| 97 | -167x | +
- rsp <- as.logical(df)+ #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions, |
|
| 98 |
- } else {
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 99 | -! | +
- rsp <- as.logical(df[[.var]])+ #' the statistics from `s_count_missed_doses()` to the table layout. |
|
| 100 |
- }+ #' |
||
| 101 | -167x | +
- n <- sum(rsp)+ #' @examples |
|
| 102 | -167x | +
- p_hat <- mean(rsp)+ #' library(dplyr) |
|
| 103 |
-
+ #' |
||
| 104 | -167x | +
- prop_ci <- switch(method,+ #' anl <- tern_ex_adsl %>% |
|
| 105 | -167x | +
- "clopper-pearson" = prop_clopper_pearson(rsp, conf_level),+ #' distinct(STUDYID, USUBJID, ARM) %>% |
|
| 106 | -167x | +
- "wilson" = prop_wilson(rsp, conf_level),+ #' mutate( |
|
| 107 | -167x | +
- "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),+ #' PARAMCD = "TNDOSMIS", |
|
| 108 | -167x | +
- "strat_wilson" = prop_strat_wilson(rsp,+ #' PARAM = "Total number of missed doses during study", |
|
| 109 | -167x | +
- strata,+ #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE), |
|
| 110 | -167x | +
- weights,+ #' AVALC = "" |
|
| 111 | -167x | +
- conf_level,+ #' ) |
|
| 112 | -167x | +
- max_iterations,+ #' |
|
| 113 | -167x | +
- correct = FALSE+ #' basic_table() %>% |
|
| 114 | -167x | +
- )$conf_int,+ #' split_cols_by("ARM") %>%
|
|
| 115 | -167x | +
- "strat_wilsonc" = prop_strat_wilson(rsp,+ #' add_colcounts() %>% |
|
| 116 | -167x | +
- strata,+ #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
|
|
| 117 | -167x | +
- weights,+ #' build_table(anl, alt_counts_df = tern_ex_adsl) |
|
| 118 | -167x | +
- conf_level,+ #' |
|
| 119 | -167x | +
- max_iterations,+ #' @export |
|
| 120 | -167x | +
- correct = TRUE+ #' @order 2 |
|
| 121 | -167x | +
- )$conf_int,+ count_missed_doses <- function(lyt, |
|
| 122 | -167x | +
- "wald" = prop_wald(rsp, conf_level),+ vars, |
|
| 123 | -167x | +
- "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),+ thresholds, |
|
| 124 | -167x | +
- "agresti-coull" = prop_agresti_coull(rsp, conf_level),+ var_labels = vars, |
|
| 125 | -167x | +
- "jeffreys" = prop_jeffreys(rsp, conf_level)+ show_labels = "visible", |
|
| 126 |
- )+ na_str = default_na_str(), |
||
| 127 |
-
+ nested = TRUE, |
||
| 128 | -167x | +
- list(+ ..., |
|
| 129 | -167x | +
- "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),+ table_names = vars, |
|
| 130 | -167x | +
- "prop_ci" = formatters::with_label(+ .stats = NULL, |
|
| 131 | -167x | +
- x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)+ .formats = NULL, |
|
| 132 |
- )+ .labels = NULL, |
||
| 133 |
- )+ .indent_mods = NULL) {
|
||
| 134 | -+ | 2x |
- }+ extra_args <- list(thresholds = thresholds, ...) |
| 136 | -+ | 2x |
- #' @describeIn estimate_proportion Formatted analysis function which is used as `afun`+ afun <- make_afun( |
| 137 | -+ | 2x |
- #' in `estimate_proportion()`.+ a_count_missed_doses, |
| 138 | -+ | 2x |
- #'+ .stats = .stats, |
| 139 | -+ | 2x |
- #' @return+ .formats = .formats, |
| 140 | -+ | 2x |
- #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ .labels = .labels, |
| 141 | -+ | 2x |
- #'+ .indent_mods = .indent_mods, |
| 142 | -+ | 2x |
- #' @export+ .ungroup_stats = "count_fraction" |
| 143 |
- a_proportion <- make_afun(+ ) |
||
| 144 | -+ | 2x |
- s_proportion,+ analyze( |
| 145 | -+ | 2x |
- .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")+ lyt = lyt, |
| 146 | -+ | 2x |
- )+ vars = vars, |
| 147 | -+ | 2x |
-
+ afun = afun, |
| 148 | -+ | 2x |
- #' @describeIn estimate_proportion Layout-creating function which can take statistics function arguments+ var_labels = var_labels, |
| 149 | -+ | 2x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ table_names = table_names, |
| 150 | -+ | 2x |
- #'+ show_labels = show_labels, |
| 151 | -+ | 2x |
- #' @return+ na_str = na_str, |
| 152 | -+ | 2x |
- #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions,+ nested = nested, |
| 153 | -+ | 2x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ extra_args = extra_args |
| 154 |
- #' the statistics from `s_proportion()` to the table layout.+ ) |
||
| 155 |
- #'+ } |
| 156 | +1 |
- #' @examples+ #' Helper functions for multivariate logistic regression |
||
| 157 | +2 |
- #' dta_test <- data.frame(+ #' |
||
| 158 | +3 |
- #' USUBJID = paste0("S", 1:12),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 159 | +4 |
- #' ARM = rep(LETTERS[1:3], each = 4),+ #' |
||
| 160 | +5 |
- #' AVAL = rep(LETTERS[1:3], each = 4)+ #' Helper functions used in calculations for logistic regression. |
||
| 161 | +6 |
- #' )+ #' |
||
| 162 | +7 |
- #'+ #' @inheritParams argument_convention |
||
| 163 | +8 |
- #' basic_table() %>%+ #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
||
| 164 | +9 |
- #' split_cols_by("ARM") %>%
+ #' Limited functionality is also available for conditional logistic regression models fitted by |
||
| 165 | +10 |
- #' estimate_proportion(vars = "AVAL") %>%+ #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()]. |
||
| 166 | +11 |
- #' build_table(df = dta_test)+ #' @param x (`character`)\cr a variable or interaction term in `fit_glm` (depending on the helper function used). |
||
| 167 | +12 |
#' |
||
| 168 | +13 |
- #' @export+ #' @examples |
||
| 169 | +14 |
- #' @order 2+ #' library(dplyr) |
||
| 170 | +15 |
- estimate_proportion <- function(lyt,+ #' library(broom) |
||
| 171 | +16 |
- vars,+ #' |
||
| 172 | +17 |
- conf_level = 0.95,+ #' adrs_f <- tern_ex_adrs %>% |
||
| 173 | +18 |
- method = c(+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 174 | +19 |
- "waldcc", "wald", "clopper-pearson",+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 175 | +20 |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ #' mutate( |
||
| 176 | +21 |
- "agresti-coull", "jeffreys"+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 177 | +22 |
- ),+ #' RACE = factor(RACE), |
||
| 178 | +23 |
- weights = NULL,+ #' SEX = factor(SEX) |
||
| 179 | +24 |
- max_iterations = 50,+ #' ) |
||
| 180 | +25 |
- variables = list(strata = NULL),+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 181 | +26 |
- long = FALSE,+ #' mod1 <- fit_logistic( |
||
| 182 | +27 |
- na_str = default_na_str(),+ #' data = adrs_f, |
||
| 183 | +28 |
- nested = TRUE,+ #' variables = list( |
||
| 184 | +29 |
- ...,+ #' response = "Response", |
||
| 185 | +30 |
- show_labels = "hidden",+ #' arm = "ARMCD", |
||
| 186 | +31 |
- table_names = vars,+ #' covariates = c("AGE", "RACE")
|
||
| 187 | +32 |
- .stats = NULL,+ #' ) |
||
| 188 | +33 |
- .formats = NULL,+ #' ) |
||
| 189 | +34 |
- .labels = NULL,+ #' mod2 <- fit_logistic( |
||
| 190 | +35 |
- .indent_mods = NULL) {
+ #' data = adrs_f, |
||
| 191 | -3x | +|||
| 36 | +
- extra_args <- list(+ #' variables = list( |
|||
| 192 | -3x | +|||
| 37 | +
- conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations,+ #' response = "Response", |
|||
| 193 | -3x | +|||
| 38 | +
- variables = variables, long = long, ...+ #' arm = "ARMCD", |
|||
| 194 | +39 |
- )+ #' covariates = c("AGE", "RACE"),
|
||
| 195 | +40 |
-
+ #' interaction = "AGE" |
||
| 196 | -3x | +|||
| 41 | +
- afun <- make_afun(+ #' ) |
|||
| 197 | -3x | +|||
| 42 | +
- a_proportion,+ #' ) |
|||
| 198 | -3x | +|||
| 43 | +
- .stats = .stats,+ #' |
|||
| 199 | -3x | +|||
| 44 | +
- .formats = .formats,+ #' @name h_logistic_regression |
|||
| 200 | -3x | +|||
| 45 | +
- .labels = .labels,+ NULL |
|||
| 201 | -3x | +|||
| 46 | +
- .indent_mods = .indent_mods+ |
|||
| 202 | +47 |
- )+ #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted |
||
| 203 | -3x | +|||
| 48 | +
- analyze(+ #' model assuming only one interaction term. |
|||
| 204 | -3x | +|||
| 49 | +
- lyt,+ #' |
|||
| 205 | -3x | +|||
| 50 | +
- vars,+ #' @return Vector of names of interaction variables. |
|||
| 206 | -3x | +|||
| 51 | +
- afun = afun,+ #'+ |
+ |||
| 52 | ++ |
+ #' @export+ |
+ ||
| 53 | ++ |
+ h_get_interaction_vars <- function(fit_glm) {
|
||
| 207 | -3x | +54 | +34x |
- na_str = na_str,+ checkmate::assert_class(fit_glm, "glm") |
| 208 | -3x | +55 | +34x |
- nested = nested,+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
| 209 | -3x | +56 | +34x |
- extra_args = extra_args,+ terms_order <- attr(stats::terms(fit_glm), "order") |
| 210 | -3x | +57 | +34x |
- show_labels = show_labels,+ interaction_term <- terms_name[terms_order == 2] |
| 211 | -3x | +58 | +34x |
- table_names = table_names+ checkmate::assert_string(interaction_term) |
| 212 | -+ | |||
| 59 | +34x |
- )+ strsplit(interaction_term, split = ":")[[1]] |
||
| 213 | +60 |
} |
||
| 214 | +61 | |||
| 215 | +62 |
- #' Helper functions for calculating proportion confidence intervals+ #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the |
||
| 216 | +63 |
- #'+ #' interaction variable names and the given levels. The main value here is that the order |
||
| 217 | +64 |
- #' @description `r lifecycle::badge("stable")`
+ #' of first and second variable is checked in the `interaction_vars` input. |
||
| 218 | +65 |
#' |
||
| 219 | +66 |
- #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].+ #' @param interaction_vars (`character(2)`)\cr interaction variable names. |
||
| 220 | +67 |
- #'+ #' @param first_var_with_level (`character(2)`)\cr the first variable name with the interaction level. |
||
| 221 | +68 |
- #' @inheritParams argument_convention+ #' @param second_var_with_level (`character(2)`)\cr the second variable name with the interaction level. |
||
| 222 | +69 |
- #' @inheritParams estimate_proportion+ #' |
||
| 223 | +70 |
- #'+ #' @return Name of coefficient. |
||
| 224 | +71 |
- #' @return Confidence interval of a proportion.+ #' |
||
| 225 | +72 |
- #'+ #' @export |
||
| 226 | +73 |
- #' @seealso [estimate_proportion], descriptive function [d_proportion()],+ h_interaction_coef_name <- function(interaction_vars, |
||
| 227 | +74 |
- #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].+ first_var_with_level, |
||
| 228 | +75 |
- #'+ second_var_with_level) {
+ |
+ ||
| 76 | +55x | +
+ checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)+ |
+ ||
| 77 | +55x | +
+ checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)+ |
+ ||
| 78 | +55x | +
+ checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)+ |
+ ||
| 79 | +55x | +
+ checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars) |
||
| 229 | +80 |
- #' @name h_proportions+ + |
+ ||
| 81 | +55x | +
+ first_name <- paste(first_var_with_level, collapse = "")+ |
+ ||
| 82 | +55x | +
+ second_name <- paste(second_var_with_level, collapse = "")+ |
+ ||
| 83 | +55x | +
+ if (first_var_with_level[1] == interaction_vars[1]) {
+ |
+ ||
| 84 | +36x | +
+ paste(first_name, second_name, sep = ":")+ |
+ ||
| 85 | +19x | +
+ } else if (second_var_with_level[1] == interaction_vars[1]) {
+ |
+ ||
| 86 | +19x | +
+ paste(second_name, first_name, sep = ":") |
||
| 230 | +87 |
- NULL+ } |
||
| 231 | +88 | ++ |
+ }+ |
+ |
| 89 | ||||
| 232 | +90 |
- #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()].+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 233 | +91 |
- #' Also referred to as Wilson score interval.+ #' for the case when both the odds ratio and the interaction variable are categorical. |
||
| 234 | +92 |
#' |
||
| 235 | +93 |
- #' @examples+ #' @param odds_ratio_var (`string`)\cr the odds ratio variable. |
||
| 236 | +94 |
- #' rsp <- c(+ #' @param interaction_var (`string`)\cr the interaction variable. |
||
| 237 | +95 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ #' |
||
| 238 | +96 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ #' @return Odds ratio. |
||
| 239 | +97 |
- #' )+ #' |
||
| 240 | +98 |
- #' prop_wilson(rsp, conf_level = 0.9)+ #' @export |
||
| 241 | +99 |
- #'+ h_or_cat_interaction <- function(odds_ratio_var, |
||
| 242 | +100 |
- #' @export+ interaction_var, |
||
| 243 | +101 |
- prop_wilson <- function(rsp, conf_level, correct = FALSE) {
+ fit_glm, |
||
| 244 | -5x | +|||
| 102 | +
- y <- stats::prop.test(+ conf_level = 0.95) {
|
|||
| 245 | -5x | +103 | +8x |
- sum(rsp),+ interaction_vars <- h_get_interaction_vars(fit_glm) |
| 246 | -5x | +104 | +8x |
- length(rsp),+ checkmate::assert_string(odds_ratio_var) |
| 247 | -5x | +105 | +8x |
- correct = correct,+ checkmate::assert_string(interaction_var) |
| 248 | -5x | +106 | +8x |
- conf.level = conf_level+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
| 249 | -+ | |||
| 107 | +8x |
- )+ checkmate::assert_vector(interaction_vars, len = 2) |
||
| 250 | +108 | |||
| 251 | -5x | +109 | +8x |
- as.numeric(y$conf.int)+ xs_level <- fit_glm$xlevels |
| 252 | -+ | |||
| 110 | +8x |
- }+ xs_coef <- stats::coef(fit_glm) |
||
| 253 | -+ | |||
| 111 | +8x |
-
+ xs_vcov <- stats::vcov(fit_glm) |
||
| 254 | -+ | |||
| 112 | +8x |
- #' @describeIn h_proportions Calculates the stratified Wilson confidence+ y <- list() |
||
| 255 | -+ | |||
| 113 | +8x |
- #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
|
||
| 256 | -+ | |||
| 114 | +14x |
- #'+ x <- list() |
||
| 257 | -+ | |||
| 115 | +14x |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ for (ref_level in xs_level[[interaction_var]]) {
|
||
| 258 | -+ | |||
| 116 | +38x |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ coef_names <- paste0(odds_ratio_var, var_level) |
||
| 259 | -+ | |||
| 117 | +38x |
- #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
+ if (ref_level != xs_level[[interaction_var]][1]) {
|
||
| 260 | -+ | |||
| 118 | +24x |
- #' minimizes the weighted squared length of the confidence interval.+ interaction_coef_name <- h_interaction_coef_name( |
||
| 261 | -+ | |||
| 119 | +24x |
- #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ interaction_vars, |
||
| 262 | -+ | |||
| 120 | +24x |
- #' to find estimates of optimal weights.+ c(odds_ratio_var, var_level), |
||
| 263 | -+ | |||
| 121 | +24x |
- #' @param correct (`flag`)\cr whether to include the continuity correction. For further information, see for example+ c(interaction_var, ref_level) |
||
| 264 | +122 |
- #' for [stats::prop.test()].+ ) |
||
| 265 | -+ | |||
| 123 | +24x |
- #'+ coef_names <- c( |
||
| 266 | -+ | |||
| 124 | +24x |
- #' @references+ coef_names, |
||
| 267 | -+ | |||
| 125 | +24x |
- #' \insertRef{Yan2010-jt}{tern}
+ interaction_coef_name |
||
| 268 | +126 |
- #'+ ) |
||
| 269 | +127 |
- #' @examples+ } |
||
| 270 | -+ | |||
| 128 | +38x |
- #' # Stratified Wilson confidence interval with unequal probabilities+ if (length(coef_names) > 1) {
|
||
| 271 | -+ | |||
| 129 | +24x |
- #'+ ones <- t(c(1, 1)) |
||
| 272 | -+ | |||
| 130 | +24x |
- #' set.seed(1)+ est <- as.numeric(ones %*% xs_coef[coef_names]) |
||
| 273 | -+ | |||
| 131 | +24x |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones))) |
||
| 274 | +132 |
- #' strata_data <- data.frame(+ } else {
|
||
| 275 | -+ | |||
| 133 | +14x |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ est <- xs_coef[coef_names] |
||
| 276 | -+ | |||
| 134 | +14x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
||
| 277 | +135 |
- #' stringsAsFactors = TRUE+ }+ |
+ ||
| 136 | +38x | +
+ or <- exp(est)+ |
+ ||
| 137 | +38x | +
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+ ||
| 138 | +38x | +
+ x[[ref_level]] <- list(or = or, ci = ci) |
||
| 278 | +139 |
- #' )+ }+ |
+ ||
| 140 | +14x | +
+ y[[var_level]] <- x |
||
| 279 | +141 |
- #' strata <- interaction(strata_data)+ }+ |
+ ||
| 142 | +8x | +
+ y |
||
| 280 | +143 |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ } |
||
| 281 | +144 |
- #'+ |
||
| 282 | +145 |
- #' prop_strat_wilson(+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 283 | +146 |
- #' rsp = rsp, strata = strata,+ #' for the case when either the odds ratio or the interaction variable is continuous. |
||
| 284 | +147 |
- #' conf_level = 0.90+ #' |
||
| 285 | +148 |
- #' )+ #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise |
||
| 286 | +149 |
- #'+ #' the median is used. |
||
| 287 | +150 |
- #' # Not automatic setting of weights+ #' |
||
| 288 | +151 |
- #' prop_strat_wilson(+ #' @return Odds ratio. |
||
| 289 | +152 |
- #' rsp = rsp, strata = strata,+ #' |
||
| 290 | +153 |
- #' weights = rep(1 / n_strata, n_strata),+ #' @note We don't provide a function for the case when both variables are continuous because |
||
| 291 | +154 |
- #' conf_level = 0.90+ #' this does not arise in this table, as the treatment arm variable will always be involved |
||
| 292 | +155 |
- #' )+ #' and categorical. |
||
| 293 | +156 |
#' |
||
| 294 | +157 |
#' @export |
||
| 295 | +158 |
- prop_strat_wilson <- function(rsp,+ h_or_cont_interaction <- function(odds_ratio_var, |
||
| 296 | +159 |
- strata,+ interaction_var, |
||
| 297 | +160 |
- weights = NULL,+ fit_glm, |
||
| 298 | +161 |
- conf_level = 0.95,+ at = NULL, |
||
| 299 | +162 |
- max_iterations = NULL,+ conf_level = 0.95) {
|
||
| 300 | -+ | |||
| 163 | +13x |
- correct = FALSE) {
+ interaction_vars <- h_get_interaction_vars(fit_glm) |
||
| 301 | -20x | +164 | +13x |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ checkmate::assert_string(odds_ratio_var) |
| 302 | -20x | +165 | +13x |
- checkmate::assert_factor(strata, len = length(rsp))+ checkmate::assert_string(interaction_var) |
| 303 | -20x | +166 | +13x |
- assert_proportion_value(conf_level)+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
| 304 | -+ | |||
| 167 | +13x |
-
+ checkmate::assert_vector(interaction_vars, len = 2) |
||
| 305 | -20x | +168 | +13x |
- tbl <- table(rsp, strata)+ checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
| 306 | -20x | +169 | +13x |
- n_strata <- length(unique(strata))+ xs_level <- fit_glm$xlevels |
| 307 | -+ | |||
| 170 | +13x |
-
+ xs_coef <- stats::coef(fit_glm) |
||
| 308 | -+ | |||
| 171 | +13x |
- # Checking the weights and maximum number of iterations.+ xs_vcov <- stats::vcov(fit_glm) |
||
| 309 | -20x | +172 | +13x |
- do_iter <- FALSE+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 310 | -20x | +173 | +13x |
- if (is.null(weights)) {
+ model_data <- fit_glm$model |
| 311 | -6x | +174 | +13x |
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ if (!is.null(at)) {
|
| 312 | -6x | +175 | +3x |
- do_iter <- TRUE+ checkmate::assert_set_equal(xs_class[interaction_var], "numeric") |
| 313 | +176 |
-
+ } |
||
| 314 | -+ | |||
| 177 | +12x |
- # Iteration parameters+ y <- list() |
||
| 315 | -2x | +178 | +12x |
- if (is.null(max_iterations)) max_iterations <- 10+ if (xs_class[interaction_var] == "numeric") {
|
| 316 | -6x | +179 | +7x |
- checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)+ if (is.null(at)) {
+ |
+
| 180 | +5x | +
+ at <- ceiling(stats::median(model_data[[interaction_var]])) |
||
| 317 | +181 |
- }+ } |
||
| 318 | -20x | +|||
| 182 | +
- checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata)+ |
|||
| 319 | -20x | +183 | +7x |
- sum_weights <- checkmate::assert_int(sum(weights))+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
|
| 320 | -! | +|||
| 184 | +14x |
- if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
+ x <- list() |
||
| 321 | -+ | |||
| 185 | +14x |
-
+ for (increment in at) {
|
||
| 322 | +186 | 20x |
- xs <- tbl["TRUE", ]+ coef_names <- paste0(odds_ratio_var, var_level) |
|
| 323 | +187 | 20x |
- ns <- colSums(tbl)+ if (increment != 0) {
|
|
| 324 | +188 | 20x |
- use_stratum <- (ns > 0)+ interaction_coef_name <- h_interaction_coef_name( |
|
| 325 | +189 | 20x |
- ns <- ns[use_stratum]+ interaction_vars, |
|
| 326 | +190 | 20x |
- xs <- xs[use_stratum]+ c(odds_ratio_var, var_level), |
|
| 327 | +191 | 20x |
- ests <- xs / ns+ c(interaction_var, "")+ |
+ |
| 192 | ++ |
+ ) |
||
| 328 | +193 | 20x |
- vars <- ests * (1 - ests) / ns+ coef_names <- c( |
|
| 329 | -+ | |||
| 194 | +20x |
-
+ coef_names, |
||
| 330 | +195 | 20x |
- strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)+ interaction_coef_name |
|
| 331 | +196 |
-
+ ) |
||
| 332 | +197 |
- # Iterative setting of weights if they were not set externally+ } |
||
| 333 | +198 | 20x |
- weights_new <- if (do_iter) {
+ if (length(coef_names) > 1) {
|
|
| 334 | -6x | +199 | +20x |
- update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights+ xvec <- t(c(1, increment)) |
| 335 | -+ | |||
| 200 | +20x |
- } else {
+ est <- as.numeric(xvec %*% xs_coef[coef_names]) |
||
| 336 | -14x | +201 | +20x |
- weights+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
| 337 | +202 |
- }+ } else {
|
||
| 338 | -+ | |||
| 203 | +! |
-
+ est <- xs_coef[coef_names] |
||
| 339 | -20x | +|||
| 204 | +! |
- strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
||
| 340 | +205 |
-
+ } |
||
| 341 | +206 | 20x |
- ci_by_strata <- Map(+ or <- exp(est) |
|
| 342 | +207 | 20x |
- function(x, n) {
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+ |
| 208 | +20x | +
+ x[[as.character(increment)]] <- list(or = or, ci = ci) |
||
| 343 | +209 |
- # Classic Wilson's confidence interval+ } |
||
| 344 | -139x | +210 | +14x |
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)+ y[[var_level]] <- x |
| 345 | +211 |
- },+ }+ |
+ ||
| 212 | ++ |
+ } else {
|
||
| 346 | -20x | +213 | +5x |
- x = xs,+ checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric") |
| 347 | -20x | +214 | +5x |
- n = ns+ checkmate::assert_set_equal(xs_class[interaction_var], "factor") |
| 348 | -+ | |||
| 215 | +5x |
- )+ for (var_level in xs_level[[interaction_var]]) {
|
||
| 349 | -20x | +216 | +15x |
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ coef_names <- odds_ratio_var |
| 350 | -20x | +217 | +15x |
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ if (var_level != xs_level[[interaction_var]][1]) {
|
| 351 | -+ | |||
| 218 | +10x |
-
+ interaction_coef_name <- h_interaction_coef_name( |
||
| 352 | -20x | +219 | +10x |
- lower <- sum(weights_new * lower_by_strata)+ interaction_vars, |
| 353 | -20x | +220 | +10x |
- upper <- sum(weights_new * upper_by_strata)+ c(odds_ratio_var, ""), |
| 354 | -+ | |||
| 221 | +10x |
-
+ c(interaction_var, var_level) |
||
| 355 | +222 |
- # Return values+ ) |
||
| 356 | -20x | +223 | +10x |
- if (do_iter) {
+ coef_names <- c( |
| 357 | -6x | +224 | +10x |
- list(+ coef_names, |
| 358 | -6x | +225 | +10x |
- conf_int = c(+ interaction_coef_name |
| 359 | -6x | +|||
| 226 | +
- lower = lower,+ )+ |
+ |||
| 227 | ++ |
+ } |
||
| 360 | -6x | +228 | +15x |
- upper = upper+ if (length(coef_names) > 1) {
|
| 361 | -+ | |||
| 229 | +10x |
- ),+ xvec <- t(c(1, 1)) |
||
| 362 | -6x | +230 | +10x |
- weights = weights_new+ est <- as.numeric(xvec %*% xs_coef[coef_names]) |
| 363 | -+ | |||
| 231 | +10x |
- )+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
||
| 364 | +232 |
- } else {
+ } else {
|
||
| 365 | -14x | +233 | +5x |
- list(+ est <- xs_coef[coef_names] |
| 366 | -14x | +234 | +5x |
- conf_int = c(+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+
| 235 | ++ |
+ } |
||
| 367 | -14x | +236 | +15x |
- lower = lower,+ or <- exp(est) |
| 368 | -14x | +237 | +15x |
- upper = upper+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
| 369 | -+ | |||
| 238 | +15x |
- )+ y[[var_level]] <- list(or = or, ci = ci) |
||
| 370 | +239 |
- )+ } |
||
| 371 | +240 |
} |
||
| 241 | +12x | +
+ y+ |
+ ||
| 372 | +242 |
} |
||
| 373 | +243 | |||
| 374 | +244 |
- #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 375 | +245 |
- #' Also referred to as the `exact` method.+ #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and |
||
| 376 | +246 |
- #'+ #' [h_or_cat_interaction()]. |
||
| 377 | +247 |
- #' @examples+ #' |
||
| 378 | +248 |
- #' prop_clopper_pearson(rsp, conf_level = .95)+ #' @return Odds ratio. |
||
| 379 | +249 |
#' |
||
| 380 | +250 |
#' @export |
||
| 381 | +251 |
- prop_clopper_pearson <- function(rsp,+ h_or_interaction <- function(odds_ratio_var, |
||
| 382 | +252 |
- conf_level) {
+ interaction_var, |
||
| 383 | -1x | +|||
| 253 | +
- y <- stats::binom.test(+ fit_glm, |
|||
| 384 | -1x | +|||
| 254 | +
- x = sum(rsp),+ at = NULL, |
|||
| 385 | -1x | +|||
| 255 | +
- n = length(rsp),+ conf_level = 0.95) {
|
|||
| 386 | -1x | -
- conf.level = conf_level- |
- ||
| 387 | -+ | 256 | +15x |
- )+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 388 | -1x | -
- as.numeric(y$conf.int)- |
- ||
| 389 | -- |
- }- |
- ||
| 390 | -- | - - | -||
| 391 | -- |
- #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition- |
- ||
| 392 | -- |
- #' for a single proportion confidence interval using the normal approximation.- |
- ||
| 393 | -+ | 257 | +15x |
- #'+ if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
|
| 394 | -+ | |||
| 258 | +9x |
- #' @param correct (`flag`)\cr whether to apply continuity correction.+ h_or_cont_interaction( |
||
| 395 | -+ | |||
| 259 | +9x |
- #'+ odds_ratio_var, |
||
| 396 | -+ | |||
| 260 | +9x |
- #' @examples+ interaction_var, |
||
| 397 | -+ | |||
| 261 | +9x |
- #' prop_wald(rsp, conf_level = 0.95)+ fit_glm, |
||
| 398 | -+ | |||
| 262 | +9x |
- #' prop_wald(rsp, conf_level = 0.95, correct = TRUE)+ at = at, |
||
| 399 | -+ | |||
| 263 | +9x |
- #'+ conf_level = conf_level |
||
| 400 | +264 |
- #' @export+ ) |
||
| 401 | -+ | |||
| 265 | +6x |
- prop_wald <- function(rsp, conf_level, correct = FALSE) {
+ } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
|
||
| 402 | -163x | +266 | +6x |
- n <- length(rsp)+ h_or_cat_interaction( |
| 403 | -163x | +267 | +6x |
- p_hat <- mean(rsp)+ odds_ratio_var, |
| 404 | -163x | +268 | +6x |
- z <- stats::qnorm((1 + conf_level) / 2)+ interaction_var, |
| 405 | -163x | +269 | +6x |
- q_hat <- 1 - p_hat+ fit_glm, |
| 406 | -163x | +270 | +6x |
- correct <- if (correct) 1 / (2 * n) else 0+ conf_level = conf_level |
| 407 | +271 | - - | -||
| 408 | -163x | -
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct+ ) |
||
| 409 | -163x | +|||
| 272 | +
- l_ci <- max(0, p_hat - err)+ } else {
|
|||
| 410 | -163x | +|||
| 273 | +! |
- u_ci <- min(1, p_hat + err)+ stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
|
||
| 411 | +274 | - - | -||
| 412 | -163x | -
- c(l_ci, u_ci)+ } |
||
| 413 | +275 |
} |
||
| 414 | +276 | |||
| 415 | +277 |
- #' @describeIn h_proportions Calculates the Agresti-Coull interval. Constructed (for 95% CI) by adding two successes+ #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table |
||
| 416 | +278 |
- #' and two failures to the data and then using the Wald formula to construct a CI.+ #' of numbers of patients. |
||
| 417 | +279 |
#' |
||
| 418 | +280 |
- #' @examples+ #' @param terms (`character`)\cr simple terms. |
||
| 419 | +281 |
- #' prop_agresti_coull(rsp, conf_level = 0.95)+ #' @param table (`table`)\cr table containing numbers for terms. |
||
| 420 | +282 |
#' |
||
| 421 | +283 |
- #' @export+ #' @return Term labels containing numbers of patients. |
||
| 422 | +284 |
- prop_agresti_coull <- function(rsp, conf_level) {
- |
- ||
| 423 | -3x | -
- n <- length(rsp)- |
- ||
| 424 | -3x | -
- x_sum <- sum(rsp)+ #' |
||
| 425 | -3x | +|||
| 285 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ #' @export |
|||
| 426 | +286 |
-
+ h_simple_term_labels <- function(terms, |
||
| 427 | +287 |
- # Add here both z^2 / 2 successes and failures.+ table) {
|
||
| 428 | -3x | +288 | +54x |
- x_sum_tilde <- x_sum + z^2 / 2+ checkmate::assert_true(is.table(table)) |
| 429 | -3x | -
- n_tilde <- n + z^2- |
- ||
| 430 | -+ | 289 | +54x |
-
+ checkmate::assert_multi_class(terms, classes = c("factor", "character"))
|
| 431 | -+ | |||
| 290 | +54x |
- # Then proceed as with the Wald interval.+ terms <- as.character(terms) |
||
| 432 | -3x | +291 | +54x |
- p_tilde <- x_sum_tilde / n_tilde+ term_n <- table[terms] |
| 433 | -3x | +292 | +54x |
- q_tilde <- 1 - p_tilde+ paste0(terms, ", n = ", term_n) |
| 434 | -3x | +|||
| 293 | +
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ } |
|||
| 435 | -3x | +|||
| 294 | +
- l_ci <- max(0, p_tilde - err)+ |
|||
| 436 | -3x | +|||
| 295 | +
- u_ci <- min(1, p_tilde + err)+ #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table |
|||
| 437 | +296 |
-
+ #' of numbers of patients. |
||
| 438 | -3x | +|||
| 297 | +
- c(l_ci, u_ci)+ #' |
|||
| 439 | +298 |
- }+ #' @param terms1 (`character`)\cr terms for first dimension (rows). |
||
| 440 | +299 |
-
+ #' @param terms2 (`character`)\cr terms for second dimension (rows). |
||
| 441 | +300 |
- #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the+ #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the |
||
| 442 | +301 |
- #' non-informative Jeffreys prior for a binomial proportion.+ #' number of patients. In that case they can only be scalar (strings). |
||
| 443 | +302 |
#' |
||
| 444 | +303 |
- #' @examples+ #' @return Term labels containing numbers of patients. |
||
| 445 | +304 |
- #' prop_jeffreys(rsp, conf_level = 0.95)+ #' |
||
| 446 | +305 |
- #'+ #' @export |
||
| 447 | +306 |
- #' @export+ h_interaction_term_labels <- function(terms1, |
||
| 448 | +307 |
- prop_jeffreys <- function(rsp,+ terms2, |
||
| 449 | +308 |
- conf_level) {
+ table, |
||
| 450 | -5x | +|||
| 309 | +
- n <- length(rsp)+ any = FALSE) {
|
|||
| 451 | -5x | +310 | +8x |
- x_sum <- sum(rsp)+ checkmate::assert_true(is.table(table)) |
| 452 | -+ | |||
| 311 | +8x |
-
+ checkmate::assert_flag(any) |
||
| 453 | -5x | +312 | +8x |
- alpha <- 1 - conf_level+ checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
|
| 454 | -5x | +313 | +8x |
- l_ci <- ifelse(+ checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
|
| 455 | -5x | +314 | +8x |
- x_sum == 0,+ terms1 <- as.character(terms1) |
| 456 | -5x | +315 | +8x |
- 0,+ terms2 <- as.character(terms2) |
| 457 | -5x | +316 | +8x |
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ if (any) {
|
| 458 | -+ | |||
| 317 | +4x |
- )+ checkmate::assert_scalar(terms1) |
||
| 459 | -+ | |||
| 318 | +4x |
-
+ checkmate::assert_scalar(terms2) |
||
| 460 | -5x | +319 | +4x |
- u_ci <- ifelse(+ paste0( |
| 461 | -5x | +320 | +4x |
- x_sum == n,+ terms1, " or ", terms2, ", n = ", |
| 462 | -5x | +|||
| 321 | +
- 1,+ # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract. |
|||
| 463 | -5x | +322 | +4x |
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2] |
| 464 | +323 |
- )+ ) |
||
| 465 | +324 |
-
+ } else {
|
||
| 466 | -5x | +325 | +4x |
- c(l_ci, u_ci)+ term_n <- table[cbind(terms1, terms2)] |
| 467 | -+ | |||
| 326 | +4x |
- }+ paste0(terms1, " * ", terms2, ", n = ", term_n) |
||
| 468 | +327 |
-
+ } |
||
| 469 | +328 |
- #' Description of the proportion summary+ } |
||
| 470 | +329 |
- #'+ |
||
| 471 | +330 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn h_logistic_regression Helper function to tabulate the main effect |
||
| 472 | +331 |
- #'+ #' results of a (conditional) logistic regression model. |
||
| 473 | +332 |
- #' This is a helper function that describes the analysis in [s_proportion()].+ #' |
||
| 474 | +333 |
- #'+ #' @return Tabulated main effect results from a logistic regression model. |
||
| 475 | +334 |
- #' @inheritParams s_proportion+ #' |
||
| 476 | +335 |
- #' @param long (`flag`)\cr whether a long or a short (default) description is required.+ #' @examples |
||
| 477 | +336 |
- #'+ #' h_glm_simple_term_extract("AGE", mod1)
|
||
| 478 | +337 |
- #' @return String describing the analysis.+ #' h_glm_simple_term_extract("ARMCD", mod1)
|
||
| 479 | +338 |
#' |
||
| 480 | +339 |
#' @export |
||
| 481 | -- |
- d_proportion <- function(conf_level,- |
- ||
| 482 | +340 |
- method,+ h_glm_simple_term_extract <- function(x, fit_glm) {
|
||
| 483 | -+ | |||
| 341 | +78x |
- long = FALSE) {
+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
|
||
| 484 | -179x | +342 | +78x |
- label <- paste0(conf_level * 100, "% CI")+ checkmate::assert_string(x) |
| 485 | +343 | |||
| 486 | -! | +|||
| 344 | +78x |
- if (long) label <- paste(label, "for Response Rates")+ xs_class <- attr(fit_glm$terms, "dataClasses") |
||
| 487 | -+ | |||
| 345 | +78x |
-
+ xs_level <- fit_glm$xlevels |
||
| 488 | -179x | +346 | +78x |
- method_part <- switch(method,+ xs_coef <- summary(fit_glm)$coefficients |
| 489 | -179x | +347 | +78x |
- "clopper-pearson" = "Clopper-Pearson",+ stats <- if (inherits(fit_glm, "glm")) {
|
| 490 | -179x | +348 | +66x |
- "waldcc" = "Wald, with correction",+ c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
|
| 491 | -179x | +|||
| 349 | +
- "wald" = "Wald, without correction",+ } else {
|
|||
| 492 | -179x | +350 | +12x |
- "wilson" = "Wilson, without correction",+ c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
|
| 493 | -179x | +|||
| 351 | +
- "strat_wilson" = "Stratified Wilson, without correction",+ } |
|||
| 494 | -179x | +|||
| 352 | +
- "wilsonc" = "Wilson, with correction",+ # Make sure x is not an interaction term. |
|||
| 495 | -179x | +353 | +78x |
- "strat_wilsonc" = "Stratified Wilson, with correction",+ checkmate::assert_subset(x, names(xs_class)) |
| 496 | -179x | +354 | +78x |
- "agresti-coull" = "Agresti-Coull",+ x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1]) |
| 497 | -179x | +355 | +78x |
- "jeffreys" = "Jeffreys",+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
| 498 | -179x | +356 | +78x |
- stop(paste(method, "does not have a description"))+ colnames(x_stats) <- names(stats) |
| 499 | -+ | |||
| 357 | +78x |
- )+ x_stats$estimate <- as.list(x_stats$estimate) |
||
| 500 | -+ | |||
| 358 | +78x |
-
+ x_stats$std_error <- as.list(x_stats$std_error) |
||
| 501 | -179x | +359 | +78x |
- paste0(label, " (", method_part, ")")
+ x_stats$pvalue <- as.list(x_stats$pvalue) |
| 502 | -+ | |||
| 360 | +78x |
- }+ x_stats$df <- as.list(1) |
||
| 503 | -+ | |||
| 361 | +78x |
-
+ if (xs_class[x] == "numeric") {
|
||
| 504 | -+ | |||
| 362 | +60x |
- #' Helper function for the estimation of stratified quantiles+ x_stats$term <- x |
||
| 505 | -+ | |||
| 363 | +60x |
- #'+ x_stats$term_label <- if (inherits(fit_glm, "glm")) {
|
||
| 506 | -+ | |||
| 364 | +48x |
- #' @description `r lifecycle::badge("stable")`
+ formatters::var_labels(fit_glm$data[x], fill = TRUE) |
||
| 507 | +365 |
- #'+ } else {
|
||
| 508 | +366 |
- #' This function wraps the estimation of stratified percentiles when we assume+ # We just fill in here with the `term` itself as we don't have the data available. |
||
| 509 | -+ | |||
| 367 | +12x |
- #' the approximation for large numbers. This is necessary only in the case+ x |
||
| 510 | +368 |
- #' proportions for each strata are unequal.+ } |
||
| 511 | -+ | |||
| 369 | +60x |
- #'+ x_stats$is_variable_summary <- FALSE |
||
| 512 | -+ | |||
| 370 | +60x |
- #' @inheritParams argument_convention+ x_stats$is_term_summary <- TRUE |
||
| 513 | +371 |
- #' @inheritParams prop_strat_wilson+ } else {
|
||
| 514 | -+ | |||
| 372 | +18x |
- #'+ checkmate::assert_class(fit_glm, "glm") |
||
| 515 | +373 |
- #' @return Stratified quantile.+ # The reason is that we don't have the original data set in the `clogit` object |
||
| 516 | +374 |
- #'+ # and therefore cannot determine the `x_numbers` here. |
||
| 517 | -+ | |||
| 375 | +18x |
- #' @seealso [prop_strat_wilson()]+ x_numbers <- table(fit_glm$data[[x]]) |
||
| 518 | -+ | |||
| 376 | +18x |
- #'+ x_stats$term <- xs_level[[x]][-1] |
||
| 519 | -+ | |||
| 377 | +18x |
- #' @examples+ x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers) |
||
| 520 | -+ | |||
| 378 | +18x |
- #' strata_data <- table(data.frame(+ x_stats$is_variable_summary <- FALSE |
||
| 521 | -+ | |||
| 379 | +18x |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ x_stats$is_term_summary <- TRUE |
||
| 522 | -+ | |||
| 380 | +18x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
||
| 523 | -+ | |||
| 381 | +18x |
- #' stringsAsFactors = TRUE+ x_main <- data.frame( |
||
| 524 | -+ | |||
| 382 | +18x |
- #' ))+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
||
| 525 | -+ | |||
| 383 | +18x |
- #' ns <- colSums(strata_data)+ term = xs_level[[x]][1], |
||
| 526 | -+ | |||
| 384 | +18x |
- #' ests <- strata_data["TRUE", ] / ns+ term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
|
||
| 527 | -+ | |||
| 385 | +18x |
- #' vars <- ests * (1 - ests) / ns+ df = main_effects[x, "Df", drop = TRUE], |
||
| 528 | -+ | |||
| 386 | +18x |
- #' weights <- rep(1 / length(ns), length(ns))+ stringsAsFactors = FALSE |
||
| 529 | +387 |
- #'+ ) |
||
| 530 | -+ | |||
| 388 | +18x |
- #' strata_normal_quantile(vars, weights, 0.95)+ x_main$pvalue <- as.list(x_main$pvalue) |
||
| 531 | -+ | |||
| 389 | +18x |
- #'+ x_main$df <- as.list(x_main$df) |
||
| 532 | -+ | |||
| 390 | +18x |
- #' @export+ x_main$estimate <- list(numeric(0)) |
||
| 533 | -+ | |||
| 391 | +18x |
- strata_normal_quantile <- function(vars, weights, conf_level) {
+ x_main$std_error <- list(numeric(0)) |
||
| 534 | -43x | +392 | +18x |
- summands <- weights^2 * vars+ if (length(xs_level[[x]][-1]) == 1) {
|
| 535 | -+ | |||
| 393 | +8x |
- # Stratified quantile+ x_main$pvalue <- list(numeric(0)) |
||
| 536 | -43x | +394 | +8x |
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)+ x_main$df <- list(numeric(0)) |
| 537 | +395 |
- }+ } |
||
| 538 | -+ | |||
| 396 | +18x |
-
+ x_main$is_variable_summary <- TRUE |
||
| 539 | -+ | |||
| 397 | +18x |
- #' Helper function for the estimation of weights for `prop_strat_wilson()`+ x_main$is_term_summary <- FALSE |
||
| 540 | -+ | |||
| 398 | +18x |
- #'+ x_stats <- rbind(x_main, x_stats) |
||
| 541 | +399 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 542 | -+ | |||
| 400 | +78x |
- #'+ x_stats$variable <- x |
||
| 543 | -+ | |||
| 401 | +78x |
- #' This function wraps the iteration procedure that allows you to estimate+ x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
|
||
| 544 | -+ | |||
| 402 | +66x |
- #' the weights for each proportional strata. This assumes to minimize the+ formatters::var_labels(fit_glm$data[x], fill = TRUE) |
||
| 545 | +403 |
- #' weighted squared length of the confidence interval.+ } else {
|
||
| 546 | -+ | |||
| 404 | +12x |
- #'+ x |
||
| 547 | +405 |
- #' @inheritParams prop_strat_wilson+ } |
||
| 548 | -+ | |||
| 406 | +78x |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ x_stats$interaction <- "" |
||
| 549 | -+ | |||
| 407 | +78x |
- #' @param strata_qnorm (`numeric(1)`)\cr initial estimation with identical weights of the quantiles.+ x_stats$interaction_label <- "" |
||
| 550 | -+ | |||
| 408 | +78x |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ x_stats$reference <- "" |
||
| 551 | -+ | |||
| 409 | +78x |
- #' be optimized in the future if we need to estimate better initial weights.+ x_stats$reference_label <- "" |
||
| 552 | -+ | |||
| 410 | +78x |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ rownames(x_stats) <- NULL |
||
| 553 | -+ | |||
| 411 | +78x |
- #' @param max_iterations (`integer(1)`)\cr maximum number of iterations to be tried. Convergence is always checked.+ x_stats[c( |
||
| 554 | -+ | |||
| 412 | +78x |
- #' @param tol (`numeric(1)`)\cr tolerance threshold for convergence.+ "variable", |
||
| 555 | -+ | |||
| 413 | +78x |
- #'+ "variable_label", |
||
| 556 | -+ | |||
| 414 | +78x |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ "term", |
||
| 557 | -+ | |||
| 415 | +78x |
- #'+ "term_label", |
||
| 558 | -+ | |||
| 416 | +78x |
- #' @seealso For references and details see [prop_strat_wilson()].+ "interaction", |
||
| 559 | -+ | |||
| 417 | +78x |
- #'+ "interaction_label",+ |
+ ||
| 418 | +78x | +
+ "reference",+ |
+ ||
| 419 | +78x | +
+ "reference_label",+ |
+ ||
| 420 | +78x | +
+ "estimate",+ |
+ ||
| 421 | +78x | +
+ "std_error",+ |
+ ||
| 422 | +78x | +
+ "df",+ |
+ ||
| 423 | +78x | +
+ "pvalue",+ |
+ ||
| 424 | +78x | +
+ "is_variable_summary",+ |
+ ||
| 425 | +78x | +
+ "is_term_summary" |
||
| 560 | +426 |
- #' @examples+ )] |
||
| 561 | +427 |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ } |
||
| 562 | +428 |
- #' sq <- 0.674+ |
||
| 563 | +429 |
- #' ws <- rep(1 / length(vs), length(vs))+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction term |
||
| 564 | +430 |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ #' results of a logistic regression model. |
||
| 565 | +431 |
#' |
||
| 566 | +432 |
- #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ #' @return Tabulated interaction term results from a logistic regression model. |
||
| 567 | +433 |
#' |
||
| 568 | +434 |
- #' @export+ #' @examples |
||
| 569 | +435 |
- update_weights_strat_wilson <- function(vars,+ #' h_glm_interaction_extract("ARMCD:AGE", mod2)
|
||
| 570 | +436 |
- strata_qnorm,+ #' |
||
| 571 | +437 |
- initial_weights,+ #' @export |
||
| 572 | +438 |
- n_per_strata,+ h_glm_interaction_extract <- function(x, fit_glm) {
+ |
+ ||
| 439 | +7x | +
+ vars <- h_get_interaction_vars(fit_glm)+ |
+ ||
| 440 | +7x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses") |
||
| 573 | +441 |
- max_iterations = 50,+ + |
+ ||
| 442 | +7x | +
+ checkmate::assert_string(x) |
||
| 574 | +443 |
- conf_level = 0.95,+ |
||
| 575 | +444 |
- tol = 0.001) {
+ # Only take two-way interaction |
||
| 576 | -9x | +445 | +7x |
- it <- 0+ checkmate::assert_vector(vars, len = 2) |
| 577 | -9x | +|||
| 446 | +
- diff_v <- NULL+ |
|||
| 578 | +447 |
-
+ # Only consider simple case: first variable in interaction is arm, a categorical variable |
||
| 579 | -9x | +448 | +7x |
- while (it < max_iterations) {
+ checkmate::assert_disjunct(xs_class[vars[1]], "numeric")+ |
+
| 449 | ++ | + | ||
| 580 | -21x | +450 | +7x |
- it <- it + 1+ xs_level <- fit_glm$xlevels |
| 581 | -21x | +451 | +7x |
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ xs_coef <- summary(fit_glm)$coefficients |
| 582 | -21x | +452 | +7x |
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
| 583 | -21x | +453 | +7x |
- weights_new <- weights_new_t / weights_new_b+ stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
|
| 584 | -21x | +454 | +7x |
- weights_new <- weights_new / sum(weights_new)+ v1_comp <- xs_level[[vars[1]]][-1] |
| 585 | -21x | +455 | +7x |
- strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)+ if (xs_class[vars[2]] == "numeric") {
|
| 586 | -21x | +456 | +4x |
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ x_stats <- as.data.frame( |
| 587 | -8x | +457 | +4x |
- if (diff_v[length(diff_v)] < tol) break+ xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE], |
| 588 | -13x | +458 | +4x |
- initial_weights <- weights_new+ stringsAsFactors = FALSE |
| 589 | +459 |
- }+ ) |
||
| 590 | -+ | |||
| 460 | +4x |
-
+ colnames(x_stats) <- names(stats) |
||
| 591 | -9x | +461 | +4x |
- if (it == max_iterations) {
+ x_stats$term <- v1_comp |
| 592 | -1x | +462 | +4x |
- warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
+ x_numbers <- table(fit_glm$data[[vars[1]]]) |
| 593 | -+ | |||
| 463 | +4x |
- }+ x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers) |
||
| 594 | -+ | |||
| 464 | +4x |
-
+ v1_ref <- xs_level[[vars[1]]][1] |
||
| 595 | -9x | +465 | +4x |
- list(+ term_main <- v1_ref |
| 596 | -9x | +466 | +4x |
- "n_it" = it,+ ref_label <- h_simple_term_labels(v1_ref, x_numbers) |
| 597 | -9x | +467 | +3x |
- "weights" = weights_new,+ } else if (xs_class[vars[2]] != "numeric") {
|
| 598 | -9x | +468 | +3x |
- "diff_v" = diff_v+ v2_comp <- xs_level[[vars[2]]][-1] |
| 599 | -+ | |||
| 469 | +3x |
- )+ v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp) |
||
| 600 | -+ | |||
| 470 | +3x |
- }+ x_sel <- paste( |
| 1 | -+ | |||
| 471 | +3x |
- #' Helper functions for multivariate logistic regression+ paste0(vars[1], v1_v2_grid$v1), |
||
| 2 | -+ | |||
| 472 | +3x |
- #'+ paste0(vars[2], v1_v2_grid$v2), |
||
| 3 | -+ | |||
| 473 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ sep = ":" |
||
| 4 | +474 |
- #'+ ) |
||
| 5 | -+ | |||
| 475 | +3x |
- #' Helper functions used in calculations for logistic regression.+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
||
| 6 | -+ | |||
| 476 | +3x |
- #'+ colnames(x_stats) <- names(stats) |
||
| 7 | -+ | |||
| 477 | +3x |
- #' @inheritParams argument_convention+ x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2) |
||
| 8 | -+ | |||
| 478 | +3x |
- #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.+ x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]]) |
||
| 9 | -+ | |||
| 479 | +3x |
- #' Limited functionality is also available for conditional logistic regression models fitted by+ x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers) |
||
| 10 | -+ | |||
| 480 | +3x |
- #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()].+ v1_ref <- xs_level[[vars[1]]][1] |
||
| 11 | -+ | |||
| 481 | +3x |
- #' @param x (`character`)\cr a variable or interaction term in `fit_glm` (depending on the helper function used).+ v2_ref <- xs_level[[vars[2]]][1] |
||
| 12 | -+ | |||
| 482 | +3x |
- #'+ term_main <- paste(vars[1], vars[2], sep = " * ") |
||
| 13 | -+ | |||
| 483 | +3x |
- #' @examples+ ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE) |
||
| 14 | +484 |
- #' library(dplyr)+ } |
||
| 15 | -+ | |||
| 485 | +7x |
- #' library(broom)+ x_stats$df <- as.list(1) |
||
| 16 | -+ | |||
| 486 | +7x |
- #'+ x_stats$pvalue <- as.list(x_stats$pvalue) |
||
| 17 | -+ | |||
| 487 | +7x |
- #' adrs_f <- tern_ex_adrs %>%+ x_stats$is_variable_summary <- FALSE |
||
| 18 | -+ | |||
| 488 | +7x |
- #' filter(PARAMCD == "BESRSPI") %>%+ x_stats$is_term_summary <- TRUE |
||
| 19 | -+ | |||
| 489 | +7x |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ x_main <- data.frame( |
||
| 20 | -+ | |||
| 490 | +7x |
- #' mutate(+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
||
| 21 | -+ | |||
| 491 | +7x |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ term = term_main, |
||
| 22 | -+ | |||
| 492 | +7x |
- #' RACE = factor(RACE),+ term_label = paste("Reference", ref_label),
|
||
| 23 | -+ | |||
| 493 | +7x |
- #' SEX = factor(SEX)+ df = main_effects[x, "Df", drop = TRUE], |
||
| 24 | -+ | |||
| 494 | +7x |
- #' )+ stringsAsFactors = FALSE |
||
| 25 | +495 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ ) |
||
| 26 | -+ | |||
| 496 | +7x |
- #' mod1 <- fit_logistic(+ x_main$pvalue <- as.list(x_main$pvalue) |
||
| 27 | -+ | |||
| 497 | +7x |
- #' data = adrs_f,+ x_main$df <- as.list(x_main$df) |
||
| 28 | -+ | |||
| 498 | +7x |
- #' variables = list(+ x_main$estimate <- list(numeric(0)) |
||
| 29 | -+ | |||
| 499 | +7x |
- #' response = "Response",+ x_main$std_error <- list(numeric(0)) |
||
| 30 | -+ | |||
| 500 | +7x |
- #' arm = "ARMCD",+ x_main$is_variable_summary <- TRUE |
||
| 31 | -+ | |||
| 501 | +7x |
- #' covariates = c("AGE", "RACE")
+ x_main$is_term_summary <- FALSE |
||
| 32 | +502 |
- #' )+ |
||
| 33 | -+ | |||
| 503 | +7x |
- #' )+ x_stats <- rbind(x_main, x_stats) |
||
| 34 | -+ | |||
| 504 | +7x |
- #' mod2 <- fit_logistic(+ x_stats$variable <- x |
||
| 35 | -+ | |||
| 505 | +7x |
- #' data = adrs_f,+ x_stats$variable_label <- paste( |
||
| 36 | -+ | |||
| 506 | +7x |
- #' variables = list(+ "Interaction of", |
||
| 37 | -+ | |||
| 507 | +7x |
- #' response = "Response",+ formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE), |
||
| 38 | +508 |
- #' arm = "ARMCD",+ "*", |
||
| 39 | -+ | |||
| 509 | +7x |
- #' covariates = c("AGE", "RACE"),
+ formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE) |
||
| 40 | +510 |
- #' interaction = "AGE"+ ) |
||
| 41 | -+ | |||
| 511 | +7x |
- #' )+ x_stats$interaction <- "" |
||
| 42 | -+ | |||
| 512 | +7x |
- #' )+ x_stats$interaction_label <- "" |
||
| 43 | -+ | |||
| 513 | +7x |
- #'+ x_stats$reference <- "" |
||
| 44 | -+ | |||
| 514 | +7x |
- #' @name h_logistic_regression+ x_stats$reference_label <- "" |
||
| 45 | -+ | |||
| 515 | +7x |
- NULL+ rownames(x_stats) <- NULL |
||
| 46 | -+ | |||
| 516 | +7x |
-
+ x_stats[c( |
||
| 47 | -+ | |||
| 517 | +7x |
- #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted+ "variable", |
||
| 48 | -+ | |||
| 518 | +7x |
- #' model assuming only one interaction term.+ "variable_label", |
||
| 49 | -+ | |||
| 519 | +7x |
- #'+ "term", |
||
| 50 | -+ | |||
| 520 | +7x |
- #' @return Vector of names of interaction variables.+ "term_label", |
||
| 51 | -+ | |||
| 521 | +7x |
- #'+ "interaction", |
||
| 52 | -+ | |||
| 522 | +7x |
- #' @export+ "interaction_label", |
||
| 53 | -+ | |||
| 523 | +7x |
- h_get_interaction_vars <- function(fit_glm) {
+ "reference", |
||
| 54 | -34x | +524 | +7x |
- checkmate::assert_class(fit_glm, "glm")+ "reference_label", |
| 55 | -34x | +525 | +7x |
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ "estimate", |
| 56 | -34x | +526 | +7x |
- terms_order <- attr(stats::terms(fit_glm), "order")+ "std_error", |
| 57 | -34x | +527 | +7x |
- interaction_term <- terms_name[terms_order == 2]+ "df", |
| 58 | -34x | +528 | +7x |
- checkmate::assert_string(interaction_term)+ "pvalue", |
| 59 | -34x | +529 | +7x |
- strsplit(interaction_term, split = ":")[[1]]+ "is_variable_summary",+ |
+
| 530 | +7x | +
+ "is_term_summary" |
||
| 60 | +531 | ++ |
+ )]+ |
+ |
| 532 |
} |
|||
| 61 | +533 | |||
| 62 | +534 |
- #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction |
||
| 63 | +535 |
- #' interaction variable names and the given levels. The main value here is that the order+ #' results of a logistic regression model. This basically is a wrapper for |
||
| 64 | +536 |
- #' of first and second variable is checked in the `interaction_vars` input.+ #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results |
||
| 65 | +537 |
- #'+ #' in the right data frame format. |
||
| 66 | +538 |
- #' @param interaction_vars (`character(2)`)\cr interaction variable names.+ #' |
||
| 67 | +539 |
- #' @param first_var_with_level (`character(2)`)\cr the first variable name with the interaction level.+ #' @return A `data.frame` of tabulated interaction term results from a logistic regression model. |
||
| 68 | +540 |
- #' @param second_var_with_level (`character(2)`)\cr the second variable name with the interaction level.+ #' |
||
| 69 | +541 |
- #'+ #' @examples |
||
| 70 | +542 |
- #' @return Name of coefficient.+ #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
|
||
| 71 | +543 |
#' |
||
| 72 | +544 |
#' @export |
||
| 73 | +545 |
- h_interaction_coef_name <- function(interaction_vars,+ h_glm_inter_term_extract <- function(odds_ratio_var, |
||
| 74 | +546 |
- first_var_with_level,+ interaction_var, |
||
| 75 | +547 |
- second_var_with_level) {
+ fit_glm, |
||
| 76 | -55x | +|||
| 548 | +
- checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)+ ...) {
|
|||
| 77 | -55x | +|||
| 549 | +
- checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)+ # First obtain the main effects. |
|||
| 78 | -55x | +550 | +13x |
- checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)+ main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm) |
| 79 | -55x | +551 | +13x |
- checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)+ main_stats$is_reference_summary <- FALSE |
| 80 | -+ | |||
| 552 | +13x |
-
+ main_stats$odds_ratio <- NA |
||
| 81 | -55x | +553 | +13x |
- first_name <- paste(first_var_with_level, collapse = "")+ main_stats$lcl <- NA |
| 82 | -55x | +554 | +13x |
- second_name <- paste(second_var_with_level, collapse = "")+ main_stats$ucl <- NA |
| 83 | -55x | +|||
| 555 | +
- if (first_var_with_level[1] == interaction_vars[1]) {
+
|
|||
| 84 | -36x | +|||
| 556 | +
- paste(first_name, second_name, sep = ":")+ # Then we get the odds ratio estimates and put into df form. |
|||
| 85 | -19x | +557 | +13x |
- } else if (second_var_with_level[1] == interaction_vars[1]) {
+ or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...) |
| 86 | -19x | +558 | +13x |
- paste(second_name, first_name, sep = ":")+ is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric" |
| 87 | +559 |
- }+ |
||
| 88 | -+ | |||
| 560 | +13x |
- }+ if (is_num_or_var) {
|
||
| 89 | +561 |
-
+ # Numeric OR variable case. |
||
| 90 | -+ | |||
| 562 | +4x |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ references <- names(or_numbers) |
||
| 91 | -+ | |||
| 563 | +4x |
- #' for the case when both the odds ratio and the interaction variable are categorical.+ n_ref <- length(references) |
||
| 92 | +564 |
- #'+ |
||
| 93 | -+ | |||
| 565 | +4x |
- #' @param odds_ratio_var (`string`)\cr the odds ratio variable.+ extract_from_list <- function(l, name, pos = 1) {
|
||
| 94 | -+ | |||
| 566 | +12x |
- #' @param interaction_var (`string`)\cr the interaction variable.+ unname(unlist( |
||
| 95 | -+ | |||
| 567 | +12x |
- #'+ lapply(or_numbers, function(x) {
|
||
| 96 | -+ | |||
| 568 | +36x |
- #' @return Odds ratio.+ x[[name]][pos] |
||
| 97 | +569 |
- #'+ }) |
||
| 98 | +570 |
- #' @export+ )) |
||
| 99 | +571 |
- h_or_cat_interaction <- function(odds_ratio_var,+ } |
||
| 100 | -+ | |||
| 572 | +4x |
- interaction_var,+ or_stats <- data.frame( |
||
| 101 | -+ | |||
| 573 | +4x |
- fit_glm,+ variable = odds_ratio_var, |
||
| 102 | -+ | |||
| 574 | +4x |
- conf_level = 0.95) {
+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
||
| 103 | -8x | +575 | +4x |
- interaction_vars <- h_get_interaction_vars(fit_glm)+ term = odds_ratio_var, |
| 104 | -8x | +576 | +4x |
- checkmate::assert_string(odds_ratio_var)+ term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
| 105 | -8x | +577 | +4x |
- checkmate::assert_string(interaction_var)+ interaction = interaction_var, |
| 106 | -8x | +578 | +4x |
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
| 107 | -8x | +579 | +4x |
- checkmate::assert_vector(interaction_vars, len = 2)+ reference = references, |
| 108 | -+ | |||
| 580 | +4x |
-
+ reference_label = references, |
||
| 109 | -8x | +581 | +4x |
- xs_level <- fit_glm$xlevels+ estimate = NA, |
| 110 | -8x | +582 | +4x |
- xs_coef <- stats::coef(fit_glm)+ std_error = NA, |
| 111 | -8x | +583 | +4x |
- xs_vcov <- stats::vcov(fit_glm)+ odds_ratio = extract_from_list(or_numbers, "or"), |
| 112 | -8x | +584 | +4x |
- y <- list()+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
| 113 | -8x | +585 | +4x |
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
| 114 | -14x | +586 | +4x |
- x <- list()+ df = NA, |
| 115 | -14x | +587 | +4x |
- for (ref_level in xs_level[[interaction_var]]) {
+ pvalue = NA, |
| 116 | -38x | +588 | +4x |
- coef_names <- paste0(odds_ratio_var, var_level)+ is_variable_summary = FALSE, |
| 117 | -38x | +589 | +4x |
- if (ref_level != xs_level[[interaction_var]][1]) {
+ is_term_summary = FALSE, |
| 118 | -24x | +590 | +4x |
- interaction_coef_name <- h_interaction_coef_name(+ is_reference_summary = TRUE |
| 119 | -24x | +|||
| 591 | +
- interaction_vars,+ )+ |
+ |||
| 592 | ++ |
+ } else {
+ |
+ ||
| 593 | ++ |
+ # Categorical OR variable case. |
||
| 120 | -24x | +594 | +9x |
- c(odds_ratio_var, var_level),+ references <- names(or_numbers[[1]]) |
| 121 | -24x | +595 | +9x |
- c(interaction_var, ref_level)+ n_ref <- length(references) |
| 122 | +596 |
- )+ |
||
| 123 | -24x | +597 | +9x |
- coef_names <- c(+ extract_from_list <- function(l, name, pos = 1) {
|
| 124 | -24x | +598 | +27x |
- coef_names,+ unname(unlist( |
| 125 | -24x | +599 | +27x |
- interaction_coef_name+ lapply(or_numbers, function(x) {
+ |
+
| 600 | +48x | +
+ lapply(x, function(y) y[[name]][pos]) |
||
| 126 | +601 |
- )+ }) |
||
| 127 | +602 |
- }+ ))+ |
+ ||
| 603 | ++ |
+ } |
||
| 128 | -38x | +604 | +9x |
- if (length(coef_names) > 1) {
+ or_stats <- data.frame( |
| 129 | -24x | +605 | +9x |
- ones <- t(c(1, 1))+ variable = odds_ratio_var, |
| 130 | -24x | +606 | +9x |
- est <- as.numeric(ones %*% xs_coef[coef_names])+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
| 131 | -24x | +607 | +9x |
- se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))+ term = rep(names(or_numbers), each = n_ref), |
| 132 | -+ | |||
| 608 | +9x |
- } else {
+ term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])), |
||
| 133 | -14x | +609 | +9x |
- est <- xs_coef[coef_names]+ interaction = interaction_var, |
| 134 | -14x | +610 | +9x |
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
| 135 | -+ | |||
| 611 | +9x |
- }+ reference = unlist(lapply(or_numbers, names)), |
||
| 136 | -38x | +612 | +9x |
- or <- exp(est)+ reference_label = unlist(lapply(or_numbers, names)), |
| 137 | -38x | +613 | +9x |
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ estimate = NA, |
| 138 | -38x | +614 | +9x |
- x[[ref_level]] <- list(or = or, ci = ci)+ std_error = NA, |
| 139 | -+ | |||
| 615 | +9x |
- }+ odds_ratio = extract_from_list(or_numbers, "or"), |
||
| 140 | -14x | +616 | +9x |
- y[[var_level]] <- x+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
| 141 | -+ | |||
| 617 | +9x |
- }+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
||
| 142 | -8x | +618 | +9x |
- y+ df = NA, |
| 143 | -+ | |||
| 619 | +9x |
- }+ pvalue = NA, |
||
| 144 | -+ | |||
| 620 | +9x |
-
+ is_variable_summary = FALSE, |
||
| 145 | -+ | |||
| 621 | +9x |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ is_term_summary = FALSE, |
||
| 146 | -+ | |||
| 622 | +9x |
- #' for the case when either the odds ratio or the interaction variable is continuous.+ is_reference_summary = TRUE |
||
| 147 | +623 |
- #'+ ) |
||
| 148 | +624 |
- #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise+ } |
||
| 149 | +625 |
- #' the median is used.+ |
||
| 150 | -+ | |||
| 626 | +13x |
- #'+ df <- rbind( |
||
| 151 | -+ | |||
| 627 | +13x |
- #' @return Odds ratio.+ main_stats[, names(or_stats)], |
||
| 152 | -+ | |||
| 628 | +13x |
- #'+ or_stats |
||
| 153 | +629 |
- #' @note We don't provide a function for the case when both variables are continuous because+ ) |
||
| 154 | -+ | |||
| 630 | +13x |
- #' this does not arise in this table, as the treatment arm variable will always be involved+ df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ] |
||
| 155 | +631 |
- #' and categorical.+ } |
||
| 156 | +632 |
- #'+ |
||
| 157 | +633 |
- #' @export+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
||
| 158 | +634 |
- h_or_cont_interaction <- function(odds_ratio_var,+ #' odds ratios and confidence intervals of simple terms. |
||
| 159 | +635 |
- interaction_var,+ #' |
||
| 160 | +636 |
- fit_glm,+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
||
| 161 | +637 |
- at = NULL,+ #' |
||
| 162 | +638 |
- conf_level = 0.95) {
+ #' @examples |
||
| 163 | -13x | +|||
| 639 | +
- interaction_vars <- h_get_interaction_vars(fit_glm)+ #' h_logistic_simple_terms("AGE", mod1)
|
|||
| 164 | -13x | +|||
| 640 | +
- checkmate::assert_string(odds_ratio_var)+ #' |
|||
| 165 | -13x | +|||
| 641 | +
- checkmate::assert_string(interaction_var)+ #' @export |
|||
| 166 | -13x | +|||
| 642 | +
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
|
|||
| 167 | -13x | +643 | +53x |
- checkmate::assert_vector(interaction_vars, len = 2)+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
|
| 168 | -13x | +644 | +53x |
- checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ if (inherits(fit_glm, "glm")) {
|
| 169 | -13x | +645 | +42x |
- xs_level <- fit_glm$xlevels+ checkmate::assert_set_equal(fit_glm$family$family, "binomial") |
| 170 | -13x | +|||
| 646 | +
- xs_coef <- stats::coef(fit_glm)+ } |
|||
| 171 | -13x | +647 | +53x |
- xs_vcov <- stats::vcov(fit_glm)+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
| 172 | -13x | +648 | +53x |
xs_class <- attr(fit_glm$terms, "dataClasses") |
| 173 | -13x | +649 | +53x |
- model_data <- fit_glm$model+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
| 174 | -13x | +650 | +53x |
- if (!is.null(at)) {
+ checkmate::assert_subset(x, terms_name) |
| 175 | -3x | +651 | +53x |
- checkmate::assert_set_equal(xs_class[interaction_var], "numeric")+ if (length(interaction) != 0) {
|
| 176 | +652 |
- }- |
- ||
| 177 | -12x | -
- y <- list()- |
- ||
| 178 | -12x | -
- if (xs_class[interaction_var] == "numeric") {
- |
- ||
| 179 | -7x | -
- if (is.null(at)) {
+ # Make sure any item in x is not part of interaction term |
||
| 180 | -5x | +653 | +2x |
- at <- ceiling(stats::median(model_data[[interaction_var]]))+ checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":"))) |
| 181 | +654 |
- }+ } |
||
| 182 | -+ | |||
| 655 | +53x |
-
+ x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm) |
||
| 183 | -7x | +656 | +53x |
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ x_stats <- do.call(rbind, x_stats) |
| 184 | -14x | +657 | +53x |
- x <- list()+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 185 | -14x | +658 | +53x |
- for (increment in at) {
+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
| 186 | -20x | +659 | +53x |
- coef_names <- paste0(odds_ratio_var, var_level)+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 187 | -20x | +660 | +53x |
- if (increment != 0) {
+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 188 | -20x | +661 | +53x |
- interaction_coef_name <- h_interaction_coef_name(+ x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl) |
| 189 | -20x | +662 | +53x |
- interaction_vars,+ x_stats |
| 190 | -20x | +|||
| 663 | +
- c(odds_ratio_var, var_level),+ } |
|||
| 191 | -20x | +|||
| 664 | +
- c(interaction_var, "")+ |
|||
| 192 | +665 |
- )+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
||
| 193 | -20x | +|||
| 666 | +
- coef_names <- c(+ #' odds ratios and confidence intervals of interaction terms. |
|||
| 194 | -20x | +|||
| 667 | +
- coef_names,+ #' |
|||
| 195 | -20x | +|||
| 668 | +
- interaction_coef_name+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
|||
| 196 | +669 |
- )+ #' |
||
| 197 | +670 |
- }+ #' @examples |
||
| 198 | -20x | +|||
| 671 | +
- if (length(coef_names) > 1) {
+ #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
|
|||
| 199 | -20x | +|||
| 672 | +
- xvec <- t(c(1, increment))+ #' |
|||
| 200 | -20x | +|||
| 673 | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ #' @export |
|||
| 201 | -20x | +|||
| 674 | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ h_logistic_inter_terms <- function(x, |
|||
| 202 | +675 |
- } else {
+ fit_glm, |
||
| 203 | -! | +|||
| 676 | +
- est <- xs_coef[coef_names]+ conf_level = 0.95, |
|||
| 204 | -! | +|||
| 677 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ at = NULL) {
|
|||
| 205 | +678 |
- }+ # Find out the interaction variables and interaction term. |
||
| 206 | -20x | +679 | +5x |
- or <- exp(est)+ inter_vars <- h_get_interaction_vars(fit_glm) |
| 207 | -20x | +680 | +5x |
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ checkmate::assert_vector(inter_vars, len = 2) |
| 208 | -20x | +|||
| 681 | +
- x[[as.character(increment)]] <- list(or = or, ci = ci)+ |
|||
| 209 | +682 |
- }+ |
||
| 210 | -14x | +683 | +5x |
- y[[var_level]] <- x+ inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))+ |
+
| 684 | +5x | +
+ inter_term <- x[inter_term_index] |
||
| 211 | +685 |
- }+ |
||
| 212 | +686 |
- } else {
+ # For the non-interaction vars we need the standard stuff. |
||
| 213 | +687 | 5x |
- checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")+ normal_terms <- setdiff(x, union(inter_vars, inter_term))+ |
+ |
| 688 | ++ | + | ||
| 214 | +689 | 5x |
- checkmate::assert_set_equal(xs_class[interaction_var], "factor")+ x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm) |
|
| 215 | +690 | 5x |
- for (var_level in xs_level[[interaction_var]]) {
+ x_stats <- do.call(rbind, x_stats) |
|
| 216 | -15x | +691 | +5x |
- coef_names <- odds_ratio_var+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 217 | -15x | +692 | +5x |
- if (var_level != xs_level[[interaction_var]][1]) {
+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
| 218 | -10x | +693 | +5x |
- interaction_coef_name <- h_interaction_coef_name(+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 219 | -10x | +694 | +5x |
- interaction_vars,+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 220 | -10x | +695 | +5x |
- c(odds_ratio_var, ""),+ normal_stats <- x_stats |
| 221 | -10x | +696 | +5x |
- c(interaction_var, var_level)+ normal_stats$is_reference_summary <- FALSE |
| 222 | +697 |
- )+ |
||
| 223 | -10x | +|||
| 698 | +
- coef_names <- c(+ # Now the interaction term itself. |
|||
| 224 | -10x | +699 | +5x |
- coef_names,+ inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm) |
| 225 | -10x | +700 | +5x |
- interaction_coef_name+ inter_term_stats$odds_ratio <- NA |
| 226 | -+ | |||
| 701 | +5x |
- )+ inter_term_stats$lcl <- NA |
||
| 227 | -+ | |||
| 702 | +5x |
- }+ inter_term_stats$ucl <- NA |
||
| 228 | -15x | +703 | +5x |
- if (length(coef_names) > 1) {
+ inter_term_stats$is_reference_summary <- FALSE |
| 229 | -10x | +|||
| 704 | +
- xvec <- t(c(1, 1))+ |
|||
| 230 | -10x | +705 | +5x |
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric" |
| 231 | -10x | +|||
| 706 | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ |
|||
| 232 | +707 |
- } else {
+ # Interaction stuff. |
||
| 233 | +708 | 5x |
- est <- xs_coef[coef_names]+ inter_stats_one <- h_glm_inter_term_extract( |
|
| 234 | +709 | 5x |
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ inter_vars[1], |
|
| 235 | -+ | |||
| 710 | +5x |
- }+ inter_vars[2], |
||
| 236 | -15x | +711 | +5x |
- or <- exp(est)+ fit_glm, |
| 237 | -15x | +712 | +5x |
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ conf_level = conf_level, |
| 238 | -15x | +713 | +5x |
- y[[var_level]] <- list(or = or, ci = ci)+ at = `if`(is_intervar1_numeric, NULL, at) |
| 239 | +714 |
- }+ ) |
||
| 240 | -+ | |||
| 715 | +5x |
- }+ inter_stats_two <- h_glm_inter_term_extract( |
||
| 241 | -12x | +716 | +5x |
- y+ inter_vars[2], |
| 242 | -+ | |||
| 717 | +5x |
- }+ inter_vars[1], |
||
| 243 | -+ | |||
| 718 | +5x |
-
+ fit_glm, |
||
| 244 | -+ | |||
| 719 | +5x |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ conf_level = conf_level, |
||
| 245 | -+ | |||
| 720 | +5x |
- #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and+ at = `if`(is_intervar1_numeric, at, NULL) |
||
| 246 | +721 |
- #' [h_or_cat_interaction()].+ ) |
||
| 247 | +722 |
- #'+ |
||
| 248 | +723 |
- #' @return Odds ratio.+ # Now just combine everything in one data frame. |
||
| 249 | -+ | |||
| 724 | +5x |
- #'+ col_names <- c( |
||
| 250 | -+ | |||
| 725 | +5x |
- #' @export+ "variable", |
||
| 251 | -+ | |||
| 726 | +5x |
- h_or_interaction <- function(odds_ratio_var,+ "variable_label", |
||
| 252 | -+ | |||
| 727 | +5x |
- interaction_var,+ "term", |
||
| 253 | -+ | |||
| 728 | +5x |
- fit_glm,+ "term_label", |
||
| 254 | -+ | |||
| 729 | +5x |
- at = NULL,+ "interaction", |
||
| 255 | -+ | |||
| 730 | +5x |
- conf_level = 0.95) {
+ "interaction_label", |
||
| 256 | -15x | +731 | +5x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ "reference", |
| 257 | -15x | +732 | +5x |
- if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
+ "reference_label", |
| 258 | -9x | +733 | +5x |
- h_or_cont_interaction(+ "estimate", |
| 259 | -9x | +734 | +5x |
- odds_ratio_var,+ "std_error", |
| 260 | -9x | +735 | +5x |
- interaction_var,+ "df", |
| 261 | -9x | +736 | +5x |
- fit_glm,+ "pvalue", |
| 262 | -9x | +737 | +5x |
- at = at,+ "odds_ratio", |
| 263 | -9x | -
- conf_level = conf_level- |
- ||
| 264 | -+ | 738 | +5x |
- )+ "lcl", |
| 265 | -6x | +739 | +5x |
- } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ "ucl", |
| 266 | -6x | +740 | +5x |
- h_or_cat_interaction(+ "is_variable_summary", |
| 267 | -6x | +741 | +5x |
- odds_ratio_var,+ "is_term_summary", |
| 268 | -6x | +742 | +5x |
- interaction_var,+ "is_reference_summary" |
| 269 | -6x | +|||
| 743 | +
- fit_glm,+ ) |
|||
| 270 | -6x | -
- conf_level = conf_level- |
- ||
| 271 | -+ | 744 | +5x |
- )+ df <- rbind( |
| 272 | -+ | |||
| 745 | +5x |
- } else {
+ inter_stats_one[, col_names], |
||
| 273 | -! | +|||
| 746 | +5x |
- stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
+ inter_stats_two[, col_names], |
||
| 274 | -+ | |||
| 747 | +5x |
- }+ inter_term_stats[, col_names] |
||
| 275 | +748 |
- }+ ) |
||
| 276 | -+ | |||
| 749 | +5x |
-
+ if (length(normal_terms) > 0) {
|
||
| 277 | -+ | |||
| 750 | +5x |
- #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table+ df <- rbind( |
||
| 278 | -+ | |||
| 751 | +5x |
- #' of numbers of patients.+ normal_stats[, col_names], |
||
| 279 | -+ | |||
| 752 | +5x |
- #'+ df |
||
| 280 | +753 |
- #' @param terms (`character`)\cr simple terms.+ ) |
||
| 281 | +754 |
- #' @param table (`table`)\cr table containing numbers for terms.+ } |
||
| 282 | -+ | |||
| 755 | +5x |
- #'+ df$ci <- combine_vectors(df$lcl, df$ucl) |
||
| 283 | -+ | |||
| 756 | +5x |
- #' @return Term labels containing numbers of patients.+ df |
||
| 284 | +757 |
- #'+ } |
| 285 | +1 |
- #' @export+ #' Confidence intervals for a difference of binomials |
||
| 286 | +2 |
- h_simple_term_labels <- function(terms,+ #' |
||
| 287 | +3 |
- table) {
- |
- ||
| 288 | -54x | -
- checkmate::assert_true(is.table(table))- |
- ||
| 289 | -54x | -
- checkmate::assert_multi_class(terms, classes = c("factor", "character"))
- |
- ||
| 290 | -54x | -
- terms <- as.character(terms)- |
- ||
| 291 | -54x | -
- term_n <- table[terms]- |
- ||
| 292 | -54x | -
- paste0(terms, ", n = ", term_n)+ #' @description `r lifecycle::badge("experimental")`
|
||
| 293 | +4 |
- }+ #' |
||
| 294 | +5 |
-
+ #' Several confidence intervals for the difference between proportions. |
||
| 295 | +6 |
- #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table+ #' |
||
| 296 | +7 |
- #' of numbers of patients.+ #' @name desctools_binom |
||
| 297 | +8 |
- #'+ NULL |
||
| 298 | +9 |
- #' @param terms1 (`character`)\cr terms for first dimension (rows).+ |
||
| 299 | +10 |
- #' @param terms2 (`character`)\cr terms for second dimension (rows).+ #' Recycle list of parameters |
||
| 300 | +11 |
- #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the+ #' |
||
| 301 | +12 |
- #' number of patients. In that case they can only be scalar (strings).+ #' This function recycles all supplied elements to the maximal dimension. |
||
| 302 | +13 |
#' |
||
| 303 | +14 |
- #' @return Term labels containing numbers of patients.+ #' @param ... (`any`)\cr elements to recycle. |
||
| 304 | +15 |
#' |
||
| 305 | +16 |
- #' @export+ #' @return A `list`. |
||
| 306 | +17 |
- h_interaction_term_labels <- function(terms1,+ #' |
||
| 307 | +18 |
- terms2,+ #' @keywords internal |
||
| 308 | +19 |
- table,+ #' @noRd |
||
| 309 | +20 |
- any = FALSE) {
- |
- ||
| 310 | -8x | -
- checkmate::assert_true(is.table(table))- |
- ||
| 311 | -8x | -
- checkmate::assert_flag(any)- |
- ||
| 312 | -8x | -
- checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
- |
- ||
| 313 | -8x | -
- checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
- |
- ||
| 314 | -8x | -
- terms1 <- as.character(terms1)- |
- ||
| 315 | -8x | -
- terms2 <- as.character(terms2)+ h_recycle <- function(...) {
|
||
| 316 | -8x | +21 | +78x |
- if (any) {
+ lst <- list(...) |
| 317 | -4x | +22 | +78x |
- checkmate::assert_scalar(terms1)+ maxdim <- max(lengths(lst)) |
| 318 | -4x | +23 | +78x |
- checkmate::assert_scalar(terms2)+ res <- lapply(lst, rep, length.out = maxdim) |
| 319 | -4x | +24 | +78x |
- paste0(+ attr(res, "maxdim") <- maxdim |
| 320 | -4x | +25 | +78x |
- terms1, " or ", terms2, ", n = ",+ return(res) |
| 321 | +26 |
- # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.- |
- ||
| 322 | -4x | -
- sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]+ } |
||
| 323 | +27 |
- )+ |
||
| 324 | +28 |
- } else {
- |
- ||
| 325 | -4x | -
- term_n <- table[cbind(terms1, terms2)]- |
- ||
| 326 | -4x | -
- paste0(terms1, " * ", terms2, ", n = ", term_n)+ #' @describeIn desctools_binom Several confidence intervals for the difference between proportions. |
||
| 327 | +29 |
- }+ #' |
||
| 328 | +30 |
- }+ #' @return A `matrix` of 3 values: |
||
| 329 | +31 |
-
+ #' * `est`: estimate of proportion difference. |
||
| 330 | +32 |
- #' @describeIn h_logistic_regression Helper function to tabulate the main effect+ #' * `lwr.ci`: estimate of lower end of the confidence interval. |
||
| 331 | +33 |
- #' results of a (conditional) logistic regression model.+ #' * `upr.ci`: estimate of upper end of the confidence interval. |
||
| 332 | +34 |
#' |
||
| 333 | +35 |
- #' @return Tabulated main effect results from a logistic regression model.+ #' @keywords internal |
||
| 334 | +36 |
- #'+ desctools_binom <- function(x1, |
||
| 335 | +37 |
- #' @examples+ n1, |
||
| 336 | +38 |
- #' h_glm_simple_term_extract("AGE", mod1)
+ x2, |
||
| 337 | +39 |
- #' h_glm_simple_term_extract("ARMCD", mod1)
+ n2, |
||
| 338 | +40 |
- #'+ conf.level = 0.95, # nolint |
||
| 339 | +41 |
- #' @export+ sides = c("two.sided", "left", "right"),
|
||
| 340 | +42 |
- h_glm_simple_term_extract <- function(x, fit_glm) {
- |
- ||
| 341 | -78x | -
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ method = c( |
||
| 342 | -78x | +|||
| 43 | +
- checkmate::assert_string(x)+ "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp" |
|||
| 343 | +44 |
-
+ )) {
|
||
| 344 | -78x | +45 | +26x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ if (missing(sides)) {
|
| 345 | -78x | +46 | +26x |
- xs_level <- fit_glm$xlevels+ sides <- match.arg(sides) |
| 346 | -78x | +|||
| 47 | +
- xs_coef <- summary(fit_glm)$coefficients+ } |
|||
| 347 | -78x | +48 | +26x |
- stats <- if (inherits(fit_glm, "glm")) {
+ if (missing(method)) {
|
| 348 | -66x | +49 | +1x |
- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ method <- match.arg(method) |
| 349 | +50 |
- } else {
+ } |
||
| 350 | -12x | +51 | +26x |
- c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint
|
| 351 | -+ | |||
| 52 | +26x |
- }+ if (sides != "two.sided") {
|
||
| 352 | -+ | |||
| 53 | +! |
- # Make sure x is not an interaction term.+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
||
| 353 | -78x | +|||
| 54 | +
- checkmate::assert_subset(x, names(xs_class))+ } |
|||
| 354 | -78x | +55 | +26x |
- x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ alpha <- 1 - conf.level |
| 355 | -78x | +56 | +26x |
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ kappa <- stats::qnorm(1 - alpha / 2) |
| 356 | -78x | +57 | +26x |
- colnames(x_stats) <- names(stats)+ p1_hat <- x1 / n1 |
| 357 | -78x | +58 | +26x |
- x_stats$estimate <- as.list(x_stats$estimate)+ p2_hat <- x2 / n2 |
| 358 | -78x | +59 | +26x |
- x_stats$std_error <- as.list(x_stats$std_error)+ est <- p1_hat - p2_hat |
| 359 | -78x | +60 | +26x |
- x_stats$pvalue <- as.list(x_stats$pvalue)+ switch(method, |
| 360 | -78x | +61 | +26x |
- x_stats$df <- as.list(1)+ wald = {
|
| 361 | -78x | +62 | +4x |
- if (xs_class[x] == "numeric") {
+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 362 | -60x | +63 | +4x |
- x_stats$term <- x+ term2 <- kappa * sqrt(vd) |
| 363 | -60x | +64 | +4x |
- x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ ci_lwr <- max(-1, est - term2) |
| 364 | -48x | -
- formatters::var_labels(fit_glm$data[x], fill = TRUE)- |
- ||
| 365 | -+ | 65 | +4x |
- } else {
+ ci_upr <- min(1, est + term2) |
| 366 | +66 |
- # We just fill in here with the `term` itself as we don't have the data available.+ }, |
||
| 367 | -12x | -
- x- |
- ||
| 368 | -+ | 67 | +26x |
- }+ waldcc = {
|
| 369 | -60x | +68 | +6x |
- x_stats$is_variable_summary <- FALSE+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 370 | -60x | +69 | +6x |
- x_stats$is_term_summary <- TRUE+ term2 <- kappa * sqrt(vd) |
| 371 | -+ | |||
| 70 | +6x |
- } else {
+ term2 <- term2 + 0.5 * (1 / n1 + 1 / n2) |
||
| 372 | -18x | +71 | +6x |
- checkmate::assert_class(fit_glm, "glm")+ ci_lwr <- max(-1, est - term2) |
| 373 | -+ | |||
| 72 | +6x |
- # The reason is that we don't have the original data set in the `clogit` object+ ci_upr <- min(1, est + term2) |
||
| 374 | +73 |
- # and therefore cannot determine the `x_numbers` here.+ }, |
||
| 375 | -18x | +74 | +26x |
- x_numbers <- table(fit_glm$data[[x]])+ ac = {
|
| 376 | -18x | +75 | +2x |
- x_stats$term <- xs_level[[x]][-1]+ n1 <- n1 + 2 |
| 377 | -18x | +76 | +2x |
- x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ n2 <- n2 + 2 |
| 378 | -18x | +77 | +2x |
- x_stats$is_variable_summary <- FALSE+ x1 <- x1 + 1 |
| 379 | -18x | +78 | +2x |
- x_stats$is_term_summary <- TRUE+ x2 <- x2 + 1 |
| 380 | -18x | +79 | +2x |
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ p1_hat <- x1 / n1 |
| 381 | -18x | +80 | +2x |
- x_main <- data.frame(+ p2_hat <- x2 / n2 |
| 382 | -18x | +81 | +2x |
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ est1 <- p1_hat - p2_hat |
| 383 | -18x | +82 | +2x |
- term = xs_level[[x]][1],+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 384 | -18x | +83 | +2x |
- term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ term2 <- kappa * sqrt(vd) |
| 385 | -18x | +84 | +2x |
- df = main_effects[x, "Df", drop = TRUE],+ ci_lwr <- max(-1, est1 - term2) |
| 386 | -18x | +85 | +2x |
- stringsAsFactors = FALSE+ ci_upr <- min(1, est1 + term2) |
| 387 | +86 |
- )+ }, |
||
| 388 | -18x | +87 | +26x |
- x_main$pvalue <- as.list(x_main$pvalue)+ exact = {
|
| 389 | -18x | +|||
| 88 | +! |
- x_main$df <- as.list(x_main$df)+ ci_lwr <- NA |
||
| 390 | -18x | +|||
| 89 | +! |
- x_main$estimate <- list(numeric(0))+ ci_upr <- NA+ |
+ ||
| 90 | ++ |
+ }, |
||
| 391 | -18x | +91 | +26x |
- x_main$std_error <- list(numeric(0))+ score = {
|
| 392 | -18x | +92 | +3x |
- if (length(xs_level[[x]][-1]) == 1) {
+ w1 <- desctools_binomci( |
| 393 | -8x | +93 | +3x |
- x_main$pvalue <- list(numeric(0))+ x = x1, n = n1, conf.level = conf.level, |
| 394 | -8x | +94 | +3x |
- x_main$df <- list(numeric(0))+ method = "wilson" |
| 395 | +95 |
- }+ ) |
||
| 396 | -18x | +96 | +3x |
- x_main$is_variable_summary <- TRUE+ w2 <- desctools_binomci( |
| 397 | -18x | +97 | +3x |
- x_main$is_term_summary <- FALSE+ x = x2, n = n2, conf.level = conf.level, |
| 398 | -18x | +98 | +3x |
- x_stats <- rbind(x_main, x_stats)+ method = "wilson" |
| 399 | +99 |
- }+ ) |
||
| 400 | -78x | +100 | +3x |
- x_stats$variable <- x+ l1 <- w1[2] |
| 401 | -78x | +101 | +3x |
- x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
+ u1 <- w1[3] |
| 402 | -66x | +102 | +3x |
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ l2 <- w2[2] |
| 403 | -+ | |||
| 103 | +3x |
- } else {
+ u2 <- w2[3] |
||
| 404 | -12x | +104 | +3x |
- x+ ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2)+ |
+
| 105 | +3x | +
+ ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2) |
||
| 405 | +106 |
- }+ }, |
||
| 406 | -78x | +107 | +26x |
- x_stats$interaction <- ""+ scorecc = {
|
| 407 | -78x | +108 | +1x |
- x_stats$interaction_label <- ""+ w1 <- desctools_binomci( |
| 408 | -78x | +109 | +1x |
- x_stats$reference <- ""+ x = x1, n = n1, conf.level = conf.level, |
| 409 | -78x | +110 | +1x |
- x_stats$reference_label <- ""+ method = "wilsoncc" |
| 410 | -78x | +|||
| 111 | +
- rownames(x_stats) <- NULL+ ) |
|||
| 411 | -78x | +112 | +1x |
- x_stats[c(+ w2 <- desctools_binomci( |
| 412 | -78x | +113 | +1x |
- "variable",+ x = x2, n = n2, conf.level = conf.level, |
| 413 | -78x | +114 | +1x |
- "variable_label",+ method = "wilsoncc" |
| 414 | -78x | +|||
| 115 | +
- "term",+ ) |
|||
| 415 | -78x | +116 | +1x |
- "term_label",+ l1 <- w1[2] |
| 416 | -78x | +117 | +1x |
- "interaction",+ u1 <- w1[3] |
| 417 | -78x | +118 | +1x |
- "interaction_label",+ l2 <- w2[2] |
| 418 | -78x | +119 | +1x |
- "reference",+ u2 <- w2[3] |
| 419 | -78x | +120 | +1x |
- "reference_label",+ ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 + (u2 - p2_hat)^2)) |
| 420 | -78x | +121 | +1x |
- "estimate",+ ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat - l2)^2)) |
| 421 | -78x | +|||
| 122 | +
- "std_error",+ }, |
|||
| 422 | -78x | +123 | +26x |
- "df",+ mee = {
|
| 423 | -78x | +124 | +1x |
- "pvalue",+ .score <- function(p1, n1, p2, n2, dif) {
|
| 424 | -78x | +|||
| 125 | +! |
- "is_variable_summary",+ if (dif > 1) dif <- 1 |
||
| 425 | -78x | +|||
| 126 | +! |
- "is_term_summary"+ if (dif < -1) dif <- -1 |
||
| 426 | -+ | |||
| 127 | +24x |
- )]+ diff <- p1 - p2 - dif |
||
| 427 | -+ | |||
| 128 | +24x |
- }+ if (abs(diff) == 0) {
|
||
| 428 | -+ | |||
| 129 | +! |
-
+ res <- 0 |
||
| 429 | +130 |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction term+ } else {
|
||
| 430 | -+ | |||
| 131 | +24x |
- #' results of a logistic regression model.+ t <- n2 / n1 |
||
| 431 | -+ | |||
| 132 | +24x |
- #'+ a <- 1 + t |
||
| 432 | -+ | |||
| 133 | +24x |
- #' @return Tabulated interaction term results from a logistic regression model.+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2)) |
||
| 433 | -+ | |||
| 134 | +24x |
- #'+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2 |
||
| 434 | -+ | |||
| 135 | +24x |
- #' @examples+ d <- -p1 * dif * (1 + dif) |
||
| 435 | -+ | |||
| 136 | +24x |
- #' h_glm_interaction_extract("ARMCD:AGE", mod2)
+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2 |
||
| 436 | -+ | |||
| 137 | +24x |
- #'+ if (abs(v) < .Machine$double.eps) v <- 0 |
||
| 437 | -+ | |||
| 138 | +24x |
- #' @export+ s <- sqrt((b / a / 3)^2 - c / a / 3) |
||
| 438 | -+ | |||
| 139 | +24x |
- h_glm_interaction_extract <- function(x, fit_glm) {
+ u <- ifelse(v > 0, 1, -1) * s |
||
| 439 | -7x | +140 | +24x |
- vars <- h_get_interaction_vars(fit_glm)+ w <- (3.141592654 + acos(v / u^3)) / 3 |
| 440 | -7x | +141 | +24x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ p1d <- 2 * u * cos(w) - b / a / 3 |
| 441 | -+ | |||
| 142 | +24x |
-
+ p2d <- p1d - dif |
||
| 442 | -7x | +143 | +24x |
- checkmate::assert_string(x)+ n <- n1 + n2 |
| 443 | -+ | |||
| 144 | +24x |
-
+ res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) |
||
| 444 | +145 |
- # Only take two-way interaction+ } |
||
| 445 | -7x | -
- checkmate::assert_vector(vars, len = 2)- |
- ||
| 446 | -+ | 146 | +24x |
-
+ return(sqrt(res)) |
| 447 | +147 |
- # Only consider simple case: first variable in interaction is arm, a categorical variable+ } |
||
| 448 | -7x | -
- checkmate::assert_disjunct(xs_class[vars[1]], "numeric")- |
- ||
| 449 | -+ | 148 | +1x |
-
+ pval <- function(delta) {
|
| 450 | -7x | +149 | +24x |
- xs_level <- fit_glm$xlevels+ z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta) |
| 451 | -7x | +150 | +24x |
- xs_coef <- summary(fit_glm)$coefficients+ 2 * min(stats::pnorm(z), 1 - stats::pnorm(z)) |
| 452 | -7x | +|||
| 151 | +
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ } |
|||
| 453 | -7x | +152 | +1x |
- stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ ci_lwr <- max(-1, stats::uniroot(function(delta) {
|
| 454 | -7x | +153 | +12x |
- v1_comp <- xs_level[[vars[1]]][-1]+ pval(delta) - alpha |
| 455 | -7x | +154 | +1x |
- if (xs_class[vars[2]] == "numeric") {
+ }, interval = c(-1 + 1e-06, est - 1e-06))$root) |
| 456 | -4x | +155 | +1x |
- x_stats <- as.data.frame(+ ci_upr <- min(1, stats::uniroot(function(delta) {
|
| 457 | -4x | +156 | +12x |
- xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],+ pval(delta) - alpha |
| 458 | -4x | +157 | +1x |
- stringsAsFactors = FALSE+ }, interval = c(est + 1e-06, 1 - 1e-06))$root) |
| 459 | +158 |
- )+ }, |
||
| 460 | -4x | +159 | +26x |
- colnames(x_stats) <- names(stats)+ blj = {
|
| 461 | -4x | +160 | +1x |
- x_stats$term <- v1_comp+ p1_dash <- (x1 + 0.5) / (n1 + 1) |
| 462 | -4x | +161 | +1x |
- x_numbers <- table(fit_glm$data[[vars[1]]])+ p2_dash <- (x2 + 0.5) / (n2 + 1) |
| 463 | -4x | +162 | +1x |
- x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)+ vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2 |
| 464 | -4x | +163 | +1x |
- v1_ref <- xs_level[[vars[1]]][1]+ term2 <- kappa * sqrt(vd) |
| 465 | -4x | +164 | +1x |
- term_main <- v1_ref+ est_dash <- p1_dash - p2_dash |
| 466 | -4x | +165 | +1x |
- ref_label <- h_simple_term_labels(v1_ref, x_numbers)+ ci_lwr <- max(-1, est_dash - term2) |
| 467 | -3x | +166 | +1x |
- } else if (xs_class[vars[2]] != "numeric") {
+ ci_upr <- min(1, est_dash + term2) |
| 468 | -3x | +|||
| 167 | +
- v2_comp <- xs_level[[vars[2]]][-1]+ }, |
|||
| 469 | -3x | +168 | +26x |
- v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ ha = {
|
| 470 | -3x | +169 | +5x |
- x_sel <- paste(+ term2 <- 1 / |
| 471 | -3x | +170 | +5x |
- paste0(vars[1], v1_v2_grid$v1),+ (2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1)) |
| 472 | -3x | +171 | +5x |
- paste0(vars[2], v1_v2_grid$v2),+ ci_lwr <- max(-1, est - term2) |
| 473 | -3x | +172 | +5x |
- sep = ":"+ ci_upr <- min(1, est + term2) |
| 474 | +173 |
- )+ }, |
||
| 475 | -3x | +174 | +26x |
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ mn = {
|
| 476 | -3x | +175 | +1x |
- colnames(x_stats) <- names(stats)+ .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
|
| 477 | -3x | +176 | +2x |
- x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2)+ p1 <- x1 / n1 |
| 478 | -3x | +177 | +2x |
- x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]])+ p2 <- x2 / n2 |
| 479 | -3x | +178 | +2x |
- x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers)+ p_hat <- p1 - p2 |
| 480 | -3x | +179 | +2x |
- v1_ref <- xs_level[[vars[1]]][1]+ dp <- 1 + ifelse(lower, 1, -1) * p_hat |
| 481 | -3x | +180 | +2x |
- v2_ref <- xs_level[[vars[2]]][1]+ i <- 1 |
| 482 | -3x | +181 | +2x |
- term_main <- paste(vars[1], vars[2], sep = " * ")+ while (i <= 50) {
|
| 483 | -3x | -
- ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)- |
- ||
| 484 | -+ | 182 | +46x |
- }+ dp <- 0.5 * dp |
| 485 | -7x | +183 | +46x |
- x_stats$df <- as.list(1)+ y <- p_hat + ifelse(lower, -1, 1) * dp |
| 486 | -7x | +184 | +46x |
- x_stats$pvalue <- as.list(x_stats$pvalue)+ score <- .score(p1, n1, p2, n2, y) |
| 487 | -7x | +185 | +46x |
- x_stats$is_variable_summary <- FALSE+ if (score < z) {
|
| 488 | -7x | +186 | +20x |
- x_stats$is_term_summary <- TRUE+ p_hat <- y |
| 489 | -7x | +|||
| 187 | +
- x_main <- data.frame(+ } |
|||
| 490 | -7x | +188 | +46x |
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
|
| 491 | -7x | +189 | +2x |
- term = term_main,+ (break)() |
| 492 | -7x | +|||
| 190 | +
- term_label = paste("Reference", ref_label),
+ } else {
|
|||
| 493 | -7x | +191 | +44x |
- df = main_effects[x, "Df", drop = TRUE],+ i <- i + 1 |
| 494 | -7x | +|||
| 192 | +
- stringsAsFactors = FALSE+ } |
|||
| 495 | +193 |
- )+ } |
||
| 496 | -7x | +194 | +2x |
- x_main$pvalue <- as.list(x_main$pvalue)+ return(y) |
| 497 | -7x | +|||
| 195 | +
- x_main$df <- as.list(x_main$df)+ } |
|||
| 498 | -7x | +196 | +1x |
- x_main$estimate <- list(numeric(0))+ .score <- function(p1, n1, p2, n2, dif) {
|
| 499 | -7x | +197 | +46x |
- x_main$std_error <- list(numeric(0))+ diff <- p1 - p2 - dif |
| 500 | -7x | +198 | +46x |
- x_main$is_variable_summary <- TRUE+ if (abs(diff) == 0) {
|
| 501 | -7x | +|||
| 199 | +! |
- x_main$is_term_summary <- FALSE+ res <- 0 |
||
| 502 | +200 |
-
+ } else {
|
||
| 503 | -7x | +201 | +46x |
- x_stats <- rbind(x_main, x_stats)+ t <- n2 / n1 |
| 504 | -7x | +202 | +46x |
- x_stats$variable <- x+ a <- 1 + t |
| 505 | -7x | +203 | +46x |
- x_stats$variable_label <- paste(+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2)) |
| 506 | -7x | +204 | +46x |
- "Interaction of",+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2 |
| 507 | -7x | +205 | +46x |
- formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE),+ d <- -p1 * dif * (1 + dif) |
| 508 | -+ | |||
| 206 | +46x |
- "*",+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2 |
||
| 509 | -7x | +207 | +46x |
- formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE)+ s <- sqrt((b / a / 3)^2 - c / a / 3) |
| 510 | -+ | |||
| 208 | +46x |
- )+ u <- ifelse(v > 0, 1, -1) * s |
||
| 511 | -7x | +209 | +46x |
- x_stats$interaction <- ""+ w <- (3.141592654 + acos(v / u^3)) / 3 |
| 512 | -7x | +210 | +46x |
- x_stats$interaction_label <- ""+ p1d <- 2 * u * cos(w) - b / a / 3 |
| 513 | -7x | +211 | +46x |
- x_stats$reference <- ""+ p2d <- p1d - dif |
| 514 | -7x | +212 | +46x |
- x_stats$reference_label <- ""+ n <- n1 + n2 |
| 515 | -7x | +213 | +46x |
- rownames(x_stats) <- NULL+ var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) * n / (n - 1) |
| 516 | -7x | +214 | +46x |
- x_stats[c(+ res <- diff^2 / var |
| 517 | -7x | +|||
| 215 | +
- "variable",+ } |
|||
| 518 | -7x | +216 | +46x |
- "variable_label",+ return(res) |
| 519 | -7x | +|||
| 217 | +
- "term",+ } |
|||
| 520 | -7x | +218 | +1x |
- "term_label",+ z <- stats::qchisq(conf.level, 1) |
| 521 | -7x | +219 | +1x |
- "interaction",+ ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE)) |
| 522 | -7x | +220 | +1x |
- "interaction_label",+ ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE)) |
| 523 | -7x | +|||
| 221 | +
- "reference",+ }, |
|||
| 524 | -7x | +222 | +26x |
- "reference_label",+ beal = {
|
| 525 | -7x | +|||
| 223 | +! |
- "estimate",+ a <- p1_hat + p2_hat |
||
| 526 | -7x | +|||
| 224 | +! |
- "std_error",+ b <- p1_hat - p2_hat |
||
| 527 | -7x | +|||
| 225 | +! |
- "df",+ u <- ((1 / n1) + (1 / n2)) / 4 |
||
| 528 | -7x | +|||
| 226 | +! |
- "pvalue",+ v <- ((1 / n1) - (1 / n2)) / 4 |
||
| 529 | -7x | +|||
| 227 | +! |
- "is_variable_summary",+ V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint |
||
| 530 | -7x | +|||
| 228 | +! |
- "is_term_summary"+ z <- stats::qchisq(p = 1 - alpha / 2, df = 1) |
||
| 531 | -+ | |||
| 229 | +! |
- )]+ A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint |
||
| 532 | -+ | |||
| 230 | +! |
- }+ B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint |
||
| 533 | -+ | |||
| 231 | +! |
-
+ ci_lwr <- max(-1, B - A / (1 + z * u)) |
||
| 534 | -+ | |||
| 232 | +! |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction+ ci_upr <- min(1, B + A / (1 + z * u)) |
||
| 535 | +233 |
- #' results of a logistic regression model. This basically is a wrapper for+ }, |
||
| 536 | -+ | |||
| 234 | +26x |
- #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results+ hal = {
|
||
| 537 | -+ | |||
| 235 | +1x |
- #' in the right data frame format.+ psi <- (p1_hat + p2_hat) / 2 |
||
| 538 | -+ | |||
| 236 | +1x |
- #'+ u <- (1 / n1 + 1 / n2) / 4 |
||
| 539 | -+ | |||
| 237 | +1x |
- #' @return A `data.frame` of tabulated interaction term results from a logistic regression model.+ v <- (1 / n1 - 1 / n2) / 4 |
||
| 540 | -+ | |||
| 238 | +1x |
- #'+ z <- kappa |
||
| 541 | -+ | |||
| 239 | +1x |
- #' @examples+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u) |
||
| 542 | -+ | |||
| 240 | +1x |
- #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) * |
||
| 543 | -+ | |||
| 241 | +1x |
- #'+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint |
||
| 544 | -+ | |||
| 242 | +1x |
- #' @export+ c(theta + w, theta - w) |
||
| 545 | -+ | |||
| 243 | +1x |
- h_glm_inter_term_extract <- function(odds_ratio_var,+ ci_lwr <- max(-1, theta - w) |
||
| 546 | -+ | |||
| 244 | +1x |
- interaction_var,+ ci_upr <- min(1, theta + w) |
||
| 547 | +245 |
- fit_glm,+ }, |
||
| 548 | -+ | |||
| 246 | +26x |
- ...) {
+ jp = {
|
||
| 549 | -+ | |||
| 247 | +1x |
- # First obtain the main effects.+ psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1)) |
||
| 550 | -13x | +248 | +1x |
- main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm)+ u <- (1 / n1 + 1 / n2) / 4 |
| 551 | -13x | +249 | +1x |
- main_stats$is_reference_summary <- FALSE+ v <- (1 / n1 - 1 / n2) / 4 |
| 552 | -13x | +250 | +1x |
- main_stats$odds_ratio <- NA+ z <- kappa |
| 553 | -13x | +251 | +1x |
- main_stats$lcl <- NA+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u) |
| 554 | -13x | +252 | +1x |
- main_stats$ucl <- NA+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) * |
| 555 | -+ | |||
| 253 | +1x |
-
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint |
||
| 556 | -+ | |||
| 254 | +1x |
- # Then we get the odds ratio estimates and put into df form.+ c(theta + w, theta - w) |
||
| 557 | -13x | +255 | +1x |
- or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...)+ ci_lwr <- max(-1, theta - w) |
| 558 | -13x | +256 | +1x |
- is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric"+ ci_upr <- min(1, theta + w) |
| 559 | +257 |
-
+ }, |
||
| 560 | -13x | +|||
| 258 | +
- if (is_num_or_var) {
+ ) |
|||
| 561 | -+ | |||
| 259 | +26x |
- # Numeric OR variable case.+ ci <- c( |
||
| 562 | -4x | +260 | +26x |
- references <- names(or_numbers)+ est = est, lwr.ci = min(ci_lwr, ci_upr), |
| 563 | -4x | +261 | +26x |
- n_ref <- length(references)+ upr.ci = max(ci_lwr, ci_upr) |
| 564 | +262 |
-
+ ) |
||
| 565 | -4x | +263 | +26x |
- extract_from_list <- function(l, name, pos = 1) {
+ if (sides == "left") {
|
| 566 | -12x | +|||
| 264 | +! |
- unname(unlist(+ ci[3] <- 1 |
||
| 567 | -12x | +265 | +26x |
- lapply(or_numbers, function(x) {
+ } else if (sides == "right") {
|
| 568 | -36x | +|||
| 266 | +! |
- x[[name]][pos]+ ci[2] <- -1 |
||
| 569 | +267 |
- })+ } |
||
| 570 | -+ | |||
| 268 | +26x |
- ))+ return(ci) |
||
| 571 | +269 |
- }+ } |
||
| 572 | -4x | +270 | +26x |
- or_stats <- data.frame(+ method <- match.arg(arg = method, several.ok = TRUE) |
| 573 | -4x | +271 | +26x |
- variable = odds_ratio_var,+ sides <- match.arg(arg = sides, several.ok = TRUE) |
| 574 | -4x | +272 | +26x |
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ lst <- h_recycle( |
| 575 | -4x | +273 | +26x |
- term = odds_ratio_var,+ x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level, |
| 576 | -4x | +274 | +26x |
- term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ sides = sides, method = method |
| 577 | -4x | +|||
| 275 | +
- interaction = interaction_var,+ ) |
|||
| 578 | -4x | +276 | +26x |
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
|
| 579 | -4x | +277 | +26x |
- reference = references,+ iBinomDiffCI( |
| 580 | -4x | +278 | +26x |
- reference_label = references,+ x1 = lst$x1[i], |
| 581 | -4x | +279 | +26x |
- estimate = NA,+ n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i], |
| 582 | -4x | +280 | +26x |
- std_error = NA,+ sides = lst$sides[i], method = lst$method[i] |
| 583 | -4x | +|||
| 281 | +
- odds_ratio = extract_from_list(or_numbers, "or"),+ ) |
|||
| 584 | -4x | +|||
| 282 | +
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ })) |
|||
| 585 | -4x | +283 | +26x |
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ lgn <- h_recycle(x1 = if (is.null(names(x1))) {
|
| 586 | -4x | +284 | +26x |
- df = NA,+ paste("x1", seq_along(x1), sep = ".")
|
| 587 | -4x | +|||
| 285 | +
- pvalue = NA,+ } else {
|
|||
| 588 | -4x | +|||
| 286 | +! |
- is_variable_summary = FALSE,+ names(x1) |
||
| 589 | -4x | +287 | +26x |
- is_term_summary = FALSE,+ }, n1 = if (is.null(names(n1))) {
|
| 590 | -4x | -
- is_reference_summary = TRUE- |
- ||
| 591 | -+ | 288 | +26x |
- )+ paste("n1", seq_along(n1), sep = ".")
|
| 592 | +289 |
} else {
|
||
| 593 | -+ | |||
| 290 | +! |
- # Categorical OR variable case.+ names(n1) |
||
| 594 | -9x | +291 | +26x |
- references <- names(or_numbers[[1]])+ }, x2 = if (is.null(names(x2))) {
|
| 595 | -9x | +292 | +26x |
- n_ref <- length(references)+ paste("x2", seq_along(x2), sep = ".")
|
| 596 | +293 | - - | -||
| 597 | -9x | -
- extract_from_list <- function(l, name, pos = 1) {
+ } else {
|
||
| 598 | -27x | +|||
| 294 | +! |
- unname(unlist(+ names(x2) |
||
| 599 | -27x | +295 | +26x |
- lapply(or_numbers, function(x) {
+ }, n2 = if (is.null(names(n2))) {
|
| 600 | -48x | -
- lapply(x, function(y) y[[name]][pos])- |
- ||
| 601 | -- |
- })- |
- ||
| 602 | -+ | 296 | +26x |
- ))+ paste("n2", seq_along(n2), sep = ".")
|
| 603 | +297 |
- }- |
- ||
| 604 | -9x | -
- or_stats <- data.frame(+ } else {
|
||
| 605 | -9x | +|||
| 298 | +! |
- variable = odds_ratio_var,+ names(n2) |
||
| 606 | -9x | +299 | +26x |
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ }, conf.level = conf.level, sides = sides, method = method) |
| 607 | -9x | +300 | +26x |
- term = rep(names(or_numbers), each = n_ref),+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
| 608 | -9x | +301 | +182x |
- term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])),+ length(unique(x)) != |
| 609 | -9x | +302 | +182x |
- interaction = interaction_var,+ 1 |
| 610 | -9x | +303 | +26x |
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ })]), 1, paste, collapse = ":") |
| 611 | -9x | +304 | +26x |
- reference = unlist(lapply(or_numbers, names)),+ rownames(res) <- xn |
| 612 | -9x | +305 | +26x |
- reference_label = unlist(lapply(or_numbers, names)),+ return(res) |
| 613 | -9x | +|||
| 306 | +
- estimate = NA,+ } |
|||
| 614 | -9x | +|||
| 307 | +
- std_error = NA,+ |
|||
| 615 | -9x | +|||
| 308 | +
- odds_ratio = extract_from_list(or_numbers, "or"),+ #' @describeIn desctools_binom Compute confidence intervals for binomial proportions. |
|||
| 616 | -9x | +|||
| 309 | +
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ #' |
|||
| 617 | -9x | +|||
| 310 | +
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ #' @param x (`integer(1)`)\cr number of successes. |
|||
| 618 | -9x | +|||
| 311 | +
- df = NA,+ #' @param n (`integer(1)`)\cr number of trials. |
|||
| 619 | -9x | +|||
| 312 | +
- pvalue = NA,+ #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95. |
|||
| 620 | -9x | +|||
| 313 | +
- is_variable_summary = FALSE,+ #' @param sides (`string`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default), |
|||
| 621 | -9x | +|||
| 314 | +
- is_term_summary = FALSE,+ #' `"left"`, or `"right"`. |
|||
| 622 | -9x | +|||
| 315 | +
- is_reference_summary = TRUE+ #' @param method (`string`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`, |
|||
| 623 | +316 |
- )+ #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`, |
||
| 624 | +317 |
- }+ #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`. |
||
| 625 | +318 |
-
+ #' |
||
| 626 | -13x | +|||
| 319 | +
- df <- rbind(+ #' @return A `matrix` with 3 columns containing: |
|||
| 627 | -13x | +|||
| 320 | +
- main_stats[, names(or_stats)],+ #' * `est`: estimate of proportion difference. |
|||
| 628 | -13x | +|||
| 321 | +
- or_stats+ #' * `lwr.ci`: lower end of the confidence interval. |
|||
| 629 | +322 |
- )+ #' * `upr.ci`: upper end of the confidence interval. |
||
| 630 | -13x | +|||
| 323 | +
- df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ]+ #' |
|||
| 631 | +324 |
- }+ #' @keywords internal |
||
| 632 | +325 |
-
+ desctools_binomci <- function(x, |
||
| 633 | +326 |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ n, |
||
| 634 | +327 |
- #' odds ratios and confidence intervals of simple terms.+ conf.level = 0.95, # nolint |
||
| 635 | +328 |
- #'+ sides = c("two.sided", "left", "right"),
|
||
| 636 | +329 |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ method = c( |
||
| 637 | +330 |
- #'+ "wilson", "wald", "waldcc", "agresti-coull", |
||
| 638 | +331 |
- #' @examples+ "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys", |
||
| 639 | +332 |
- #' h_logistic_simple_terms("AGE", mod1)
+ "clopper-pearson", "arcsine", "logit", "witting", "pratt", |
||
| 640 | +333 |
- #'+ "midp", "lik", "blaker" |
||
| 641 | +334 |
- #' @export+ ), |
||
| 642 | +335 |
- h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
+ rand = 123, |
||
| 643 | -53x | +|||
| 336 | +
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ tol = 1e-05) {
|
|||
| 644 | -53x | +337 | +26x |
- if (inherits(fit_glm, "glm")) {
+ if (missing(method)) {
|
| 645 | -42x | +338 | +1x |
- checkmate::assert_set_equal(fit_glm$family$family, "binomial")+ method <- "wilson" |
| 646 | +339 |
} |
||
| 647 | -53x | -
- terms_name <- attr(stats::terms(fit_glm), "term.labels")- |
- ||
| 648 | -53x | -
- xs_class <- attr(fit_glm$terms, "dataClasses")- |
- ||
| 649 | -53x | -
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]- |
- ||
| 650 | -53x | +340 | +26x |
- checkmate::assert_subset(x, terms_name)+ if (missing(sides)) {
|
| 651 | -53x | +341 | +25x |
- if (length(interaction) != 0) {
+ sides <- "two.sided" |
| 652 | +342 |
- # Make sure any item in x is not part of interaction term+ } |
||
| 653 | -2x | -
- checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":")))- |
- ||
| 654 | -+ | 343 | +26x |
- }+ iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint
|
| 655 | -53x | +344 | +26x |
- x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm)+ method = c( |
| 656 | -53x | +345 | +26x |
- x_stats <- do.call(rbind, x_stats)+ "wilson", "wilsoncc", "wald", |
| 657 | -53x | +346 | +26x |
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ "waldcc", "agresti-coull", "jeffreys", "modified wilson", |
| 658 | -53x | +347 | +26x |
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ "modified jeffreys", "clopper-pearson", "arcsine", "logit", |
| 659 | -53x | +348 | +26x |
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ "witting", "pratt", "midp", "lik", "blaker" |
| 660 | -53x | +|||
| 349 | +
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ ), |
|||
| 661 | -53x | +350 | +26x |
- x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl)+ rand = 123, |
| 662 | -53x | +351 | +26x |
- x_stats+ tol = 1e-05) {
|
| 663 | -+ | |||
| 352 | +26x |
- }+ if (length(x) != 1) {
|
||
| 664 | -+ | |||
| 353 | +! |
-
+ stop("'x' has to be of length 1 (number of successes)")
|
||
| 665 | +354 |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ } |
||
| 666 | -+ | |||
| 355 | +26x |
- #' odds ratios and confidence intervals of interaction terms.+ if (length(n) != 1) {
|
||
| 667 | -+ | |||
| 356 | +! |
- #'+ stop("'n' has to be of length 1 (number of trials)")
|
||
| 668 | +357 |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ } |
||
| 669 | -+ | |||
| 358 | +26x |
- #'+ if (length(conf.level) != 1) {
|
||
| 670 | -+ | |||
| 359 | +! |
- #' @examples+ stop("'conf.level' has to be of length 1 (confidence level)")
|
||
| 671 | +360 |
- #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
+ } |
||
| 672 | -+ | |||
| 361 | +26x |
- #'+ if (conf.level < 0.5 || conf.level > 1) {
|
||
| 673 | -+ | |||
| 362 | +! |
- #' @export+ stop("'conf.level' has to be in [0.5, 1]")
|
||
| 674 | +363 |
- h_logistic_inter_terms <- function(x,+ } |
||
| 675 | -+ | |||
| 364 | +26x |
- fit_glm,+ sides <- match.arg(sides, choices = c( |
||
| 676 | -+ | |||
| 365 | +26x |
- conf_level = 0.95,+ "two.sided", "left", |
||
| 677 | -+ | |||
| 366 | +26x |
- at = NULL) {
+ "right" |
||
| 678 | -+ | |||
| 367 | +26x |
- # Find out the interaction variables and interaction term.+ ), several.ok = FALSE) |
||
| 679 | -5x | +368 | +26x |
- inter_vars <- h_get_interaction_vars(fit_glm)+ if (sides != "two.sided") {
|
| 680 | -5x | +369 | +1x |
- checkmate::assert_vector(inter_vars, len = 2)+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
| 681 | +370 |
-
+ } |
||
| 682 | -+ | |||
| 371 | +26x |
-
+ alpha <- 1 - conf.level |
||
| 683 | -5x | +372 | +26x |
- inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))+ kappa <- stats::qnorm(1 - alpha / 2) |
| 684 | -5x | +373 | +26x |
- inter_term <- x[inter_term_index]+ p_hat <- x / n |
| 685 | -+ | |||
| 374 | +26x |
-
+ q_hat <- 1 - p_hat |
||
| 686 | -+ | |||
| 375 | +26x |
- # For the non-interaction vars we need the standard stuff.+ est <- p_hat |
||
| 687 | -5x | +376 | +26x |
- normal_terms <- setdiff(x, union(inter_vars, inter_term))+ switch(match.arg(arg = method, choices = c( |
| 688 | -+ | |||
| 377 | +26x |
-
+ "wilson", |
||
| 689 | -5x | +378 | +26x |
- x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm)+ "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys", |
| 690 | -5x | +379 | +26x |
- x_stats <- do.call(rbind, x_stats)+ "modified wilson", "modified jeffreys", "clopper-pearson", |
| 691 | -5x | +380 | +26x |
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ "arcsine", "logit", "witting", "pratt", "midp", "lik", |
| 692 | -5x | +381 | +26x |
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ "blaker" |
| 693 | -5x | +|||
| 382 | +
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ )), |
|||
| 694 | -5x | +383 | +26x |
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ wald = {
|
| 695 | -5x | +384 | +1x |
- normal_stats <- x_stats+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
| 696 | -5x | +385 | +1x |
- normal_stats$is_reference_summary <- FALSE+ ci_lwr <- max(0, p_hat - term2) |
| 697 | -+ | |||
| 386 | +1x |
-
+ ci_upr <- min(1, p_hat + term2) |
||
| 698 | +387 |
- # Now the interaction term itself.+ }, |
||
| 699 | -5x | +388 | +26x |
- inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm)+ waldcc = {
|
| 700 | -5x | +389 | +1x |
- inter_term_stats$odds_ratio <- NA+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
| 701 | -5x | +390 | +1x |
- inter_term_stats$lcl <- NA+ term2 <- term2 + 1 / (2 * n) |
| 702 | -5x | +391 | +1x |
- inter_term_stats$ucl <- NA+ ci_lwr <- max(0, p_hat - term2) |
| 703 | -5x | +392 | +1x |
- inter_term_stats$is_reference_summary <- FALSE+ ci_upr <- min(1, p_hat + term2) |
| 704 | +393 |
-
+ }, |
||
| 705 | -5x | -
- is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric"- |
- ||
| 706 | -+ | 394 | +26x |
-
+ wilson = {
|
| 707 | -+ | |||
| 395 | +8x |
- # Interaction stuff.+ term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
||
| 708 | -5x | +396 | +8x |
- inter_stats_one <- h_glm_inter_term_extract(+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n)) |
| 709 | -5x | +397 | +8x |
- inter_vars[1],+ ci_lwr <- max(0, term1 - term2) |
| 710 | -5x | +398 | +8x |
- inter_vars[2],+ ci_upr <- min(1, term1 + term2) |
| 711 | -5x | +|||
| 399 | +
- fit_glm,+ }, |
|||
| 712 | -5x | +400 | +26x |
- conf_level = conf_level,+ wilsoncc = {
|
| 713 | -5x | +401 | +3x |
- at = `if`(is_intervar1_numeric, NULL, at)+ lci <- ( |
| 714 | -+ | |||
| 402 | +3x |
- )+ 2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1)) |
||
| 715 | -5x | +403 | +3x |
- inter_stats_two <- h_glm_inter_term_extract(+ ) / (2 * (n + kappa^2)) |
| 716 | -5x | +404 | +3x |
- inter_vars[2],+ uci <- ( |
| 717 | -5x | +405 | +3x |
- inter_vars[1],+ 2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1)) |
| 718 | -5x | +406 | +3x |
- fit_glm,+ ) / (2 * (n + kappa^2)) |
| 719 | -5x | +407 | +3x |
- conf_level = conf_level,+ ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci)) |
| 720 | -5x | +408 | +3x |
- at = `if`(is_intervar1_numeric, at, NULL)+ ci_upr <- min(1, ifelse(p_hat == 1, 1, uci)) |
| 721 | +409 |
- )+ }, |
||
| 722 | -+ | |||
| 410 | +26x |
-
+ `agresti-coull` = {
|
||
| 723 | -+ | |||
| 411 | +1x |
- # Now just combine everything in one data frame.+ x_tilde <- x + kappa^2 / 2 |
||
| 724 | -5x | +412 | +1x |
- col_names <- c(+ n_tilde <- n + kappa^2 |
| 725 | -5x | +413 | +1x |
- "variable",+ p_tilde <- x_tilde / n_tilde |
| 726 | -5x | +414 | +1x |
- "variable_label",+ q_tilde <- 1 - p_tilde |
| 727 | -5x | +415 | +1x |
- "term",+ est <- p_tilde |
| 728 | -5x | +416 | +1x |
- "term_label",+ term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
| 729 | -5x | +417 | +1x |
- "interaction",+ ci_lwr <- max(0, p_tilde - term2) |
| 730 | -5x | +418 | +1x |
- "interaction_label",+ ci_upr <- min(1, p_tilde + term2) |
| 731 | -5x | +|||
| 419 | +
- "reference",+ }, |
|||
| 732 | -5x | +420 | +26x |
- "reference_label",+ jeffreys = {
|
| 733 | -5x | +421 | +1x |
- "estimate",+ if (x == 0) {
|
| 734 | -5x | +|||
| 422 | +! |
- "std_error",+ ci_lwr <- 0 |
||
| 735 | -5x | +|||
| 423 | +
- "df",+ } else {
|
|||
| 736 | -5x | +424 | +1x |
- "pvalue",+ ci_lwr <- stats::qbeta( |
| 737 | -5x | +425 | +1x |
- "odds_ratio",+ alpha / 2, |
| 738 | -5x | +426 | +1x |
- "lcl",+ x + 0.5, n - x + 0.5 |
| 739 | -5x | +|||
| 427 | +
- "ucl",+ ) |
|||
| 740 | -5x | +|||
| 428 | +
- "is_variable_summary",+ } |
|||
| 741 | -5x | +429 | +1x |
- "is_term_summary",+ if (x == n) {
|
| 742 | -5x | +|||
| 430 | +! |
- "is_reference_summary"+ ci_upr <- 1 |
||
| 743 | +431 |
- )+ } else {
|
||
| 744 | -5x | +432 | +1x |
- df <- rbind(+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
| 745 | -5x | +|||
| 433 | +
- inter_stats_one[, col_names],+ } |
|||
| 746 | -5x | +|||
| 434 | +
- inter_stats_two[, col_names],+ }, |
|||
| 747 | -5x | +435 | +26x |
- inter_term_stats[, col_names]- |
-
| 748 | -- |
- )+ `modified wilson` = {
|
||
| 749 | -5x | +436 | +1x |
- if (length(normal_terms) > 0) {
+ term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
| 750 | -5x | +437 | +1x |
- df <- rbind(+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n)) |
| 751 | -5x | +438 | +1x |
- normal_stats[, col_names],+ if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) {
|
| 752 | -5x | +|||
| 439 | +! |
- df+ ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n |
||
| 753 | +440 |
- )+ } else {
+ |
+ ||
| 441 | +1x | +
+ ci_lwr <- max(0, term1 - term2) |
||
| 754 | +442 |
- }+ } |
||
| 755 | -5x | +443 | +1x |
- df$ci <- combine_vectors(df$lcl, df$ucl)+ if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) {
|
| 756 | -5x | +|||
| 444 | +! |
- df+ ci_upr <- 1 - 0.5 * stats::qchisq( |
||
| 757 | -+ | |||
| 445 | +! |
- }+ alpha, |
| 1 | -+ | |||
| 446 | +! |
- # Utility functions to cooperate with {rtables} package
+ 2 * (n - x) |
||
| 2 | -+ | |||
| 447 | +! |
-
+ ) / n |
||
| 3 | +448 |
- #' Convert table into matrix of strings+ } else {
|
||
| 4 | -+ | |||
| 449 | +1x |
- #'+ ci_upr <- min(1, term1 + term2) |
||
| 5 | +450 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 6 | +451 |
- #'+ }, |
||
| 7 | -+ | |||
| 452 | +26x |
- #' Helper function to use mostly within tests. `with_spaces`parameter allows+ `modified jeffreys` = {
|
||
| 8 | -+ | |||
| 453 | +1x |
- #' to test not only for content but also indentation and table structure.+ if (x == n) {
|
||
| 9 | -+ | |||
| 454 | +! |
- #' `print_txt_to_copy` instead facilitate the testing development by returning a well+ ci_lwr <- (alpha / 2)^(1 / n) |
||
| 10 | +455 |
- #' formatted text that needs only to be copied and pasted in the expected output.+ } else {
|
||
| 11 | -+ | |||
| 456 | +1x |
- #'+ if (x <= 1) {
|
||
| 12 | -+ | |||
| 457 | +! |
- #' @inheritParams formatters::toString+ ci_lwr <- 0 |
||
| 13 | +458 |
- #' @param x (`VTableTree`)\cr `rtables` table object.+ } else {
|
||
| 14 | -+ | |||
| 459 | +1x |
- #' @param with_spaces (`flag`)\cr whether the tested table should keep the indentation and other relevant spaces.+ ci_lwr <- stats::qbeta( |
||
| 15 | -+ | |||
| 460 | +1x |
- #' @param print_txt_to_copy (`flag`)\cr utility to have a way to copy the input table directly+ alpha / 2, |
||
| 16 | -+ | |||
| 461 | +1x |
- #' into the expected variable instead of copying it too manually.+ x + 0.5, n - x + 0.5 |
||
| 17 | +462 |
- #'+ ) |
||
| 18 | +463 |
- #' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the+ } |
||
| 19 | +464 |
- #' table will be printed to console, ready to be copied as a expected value.+ } |
||
| 20 | -+ | |||
| 465 | +1x |
- #'+ if (x == 0) {
|
||
| 21 | -+ | |||
| 466 | +! |
- #' @examples+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 22 | +467 |
- #' tbl <- basic_table() %>%+ } else {
|
||
| 23 | -+ | |||
| 468 | +1x |
- #' split_rows_by("SEX") %>%
+ if (x >= n - 1) {
|
||
| 24 | -+ | |||
| 469 | +! |
- #' split_cols_by("ARM") %>%
+ ci_upr <- 1 |
||
| 25 | +470 |
- #' analyze("AGE") %>%
+ } else {
|
||
| 26 | -+ | |||
| 471 | +1x |
- #' build_table(tern_ex_adsl)+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
||
| 27 | +472 |
- #'+ } |
||
| 28 | +473 |
- #' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2))+ } |
||
| 29 | +474 |
- #'+ }, |
||
| 30 | -+ | |||
| 475 | +26x |
- #' @export+ `clopper-pearson` = {
|
||
| 31 | -+ | |||
| 476 | +1x |
- to_string_matrix <- function(x, widths = NULL, max_width = NULL,+ ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1) |
||
| 32 | -+ | |||
| 477 | +1x |
- hsep = formatters::default_hsep(),+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x) |
||
| 33 | +478 |
- with_spaces = TRUE, print_txt_to_copy = FALSE) {
+ }, |
||
| 34 | -11x | +479 | +26x |
- checkmate::assert_flag(with_spaces)+ arcsine = {
|
| 35 | -11x | +480 | +1x |
- checkmate::assert_flag(print_txt_to_copy)+ p_tilde <- (x + 0.375) / (n + 0.75) |
| 36 | -11x | +481 | +1x |
- checkmate::assert_int(max_width, null.ok = TRUE)+ est <- p_tilde+ |
+
| 482 | +1x | +
+ ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2+ |
+ ||
| 483 | +1x | +
+ ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2 |
||
| 37 | +484 |
-
+ }, |
||
| 38 | -11x | +485 | +26x |
- if (inherits(x, "MatrixPrintForm")) {
+ logit = {
|
| 39 | -! | +|||
| 486 | +1x |
- tx <- x+ lambda_hat <- log(x / (n - x)) |
||
| 40 | -+ | |||
| 487 | +1x |
- } else {
+ V_hat <- n / (x * (n - x)) # nolint |
||
| 41 | -11x | +488 | +1x |
- tx <- matrix_form(x, TRUE)+ lambda_lower <- lambda_hat - kappa * sqrt(V_hat) |
| 42 | -+ | |||
| 489 | +1x |
- }+ lambda_upper <- lambda_hat + kappa * sqrt(V_hat)+ |
+ ||
| 490 | +1x | +
+ ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower))+ |
+ ||
| 491 | +1x | +
+ ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper)) |
||
| 43 | +492 |
-
+ }, |
||
| 44 | -11x | +493 | +26x |
- tf_wrap <- FALSE+ witting = {
|
| 45 | -11x | +494 | +1x |
- if (!is.null(max_width)) {
+ set.seed(rand) |
| 46 | -! | +|||
| 495 | +1x |
- tf_wrap <- TRUE+ x_tilde <- x + stats::runif(1, min = 0, max = 1) |
||
| 47 | -+ | |||
| 496 | +1x |
- }+ pbinom_abscont <- function(q, size, prob) {
|
||
| 48 | -+ | |||
| 497 | +22x |
-
+ v <- trunc(q) |
||
| 49 | -+ | |||
| 498 | +22x |
- # Producing the matrix to test+ term1 <- stats::pbinom(v - 1, size = size, prob = prob) |
||
| 50 | -11x | +499 | +22x |
- if (with_spaces) {
+ term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob) |
| 51 | -2x | +500 | +22x |
- out <- strsplit(toString(tx, widths = widths, tf_wrap = tf_wrap, max_width = max_width, hsep = hsep), "\n")[[1]]+ return(term1 + term2) |
| 52 | +501 |
- } else {
+ } |
||
| 53 | -9x | +502 | +1x |
- out <- tx$strings+ qbinom_abscont <- function(p, size, x) {
|
| 54 | -+ | |||
| 503 | +2x |
- }+ fun <- function(prob, size, x, p) {
|
||
| 55 | -+ | |||
| 504 | +22x |
-
+ pbinom_abscont(x, size, prob) - p |
||
| 56 | +505 |
- # Printing to console formatted output that needs to be copied in "expected"+ } |
||
| 57 | -11x | +506 | +2x |
- if (print_txt_to_copy) {
+ stats::uniroot(fun, |
| 58 | +507 | 2x |
- out_tmp <- out+ interval = c(0, 1), size = size, |
|
| 59 | +508 | 2x |
- if (!with_spaces) {
+ x = x, p = p |
|
| 60 | -1x | +509 | +2x |
- out_tmp <- apply(out, 1, paste0, collapse = '", "')+ )$root |
| 61 | +510 |
- }+ } |
||
| 62 | -2x | +511 | +1x |
- cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
+ ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde) |
| 63 | -+ | |||
| 512 | +1x |
- }+ ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde) |
||
| 64 | +513 |
-
+ }, |
||
| 65 | -+ | |||
| 514 | +26x |
- # Return values+ pratt = {
|
||
| 66 | -11x | +515 | +1x |
- return(out)+ if (x == 0) {
|
| 67 | -+ | |||
| 516 | +! |
- }+ ci_lwr <- 0 |
||
| 68 | -+ | |||
| 517 | +! |
-
+ ci_upr <- 1 - alpha^(1 / n) |
||
| 69 | -+ | |||
| 518 | +1x |
- #' Blank for missing input+ } else if (x == 1) {
|
||
| 70 | -+ | |||
| 519 | +! |
- #'+ ci_lwr <- 1 - (1 - alpha / 2)^(1 / n) |
||
| 71 | -+ | |||
| 520 | +! |
- #' Helper function to use in tabulating model results.+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 72 | -+ | |||
| 521 | +1x |
- #'+ } else if (x == (n - 1)) {
|
||
| 73 | -+ | |||
| 522 | +! |
- #' @param x (`vector`)\cr input for a cell.+ ci_lwr <- (alpha / 2)^(1 / n) |
||
| 74 | -+ | |||
| 523 | +! |
- #'+ ci_upr <- (1 - alpha / 2)^(1 / n) |
||
| 75 | -+ | |||
| 524 | +1x |
- #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise+ } else if (x == n) {
|
||
| 76 | -+ | |||
| 525 | +! |
- #' the unlisted version of `x`.+ ci_lwr <- alpha^(1 / n) |
||
| 77 | -+ | |||
| 526 | +! |
- #'+ ci_upr <- 1 |
||
| 78 | +527 |
- #' @keywords internal+ } else {
|
||
| 79 | -+ | |||
| 528 | +1x |
- unlist_and_blank_na <- function(x) {
+ z <- stats::qnorm(1 - alpha / 2) |
||
| 80 | -267x | +529 | +1x |
- unl <- unlist(x)+ A <- ((x + 1) / (n - x))^2 # nolint |
| 81 | -267x | +530 | +1x |
- if (all(is.na(unl))) {
+ B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint |
| 82 | -161x | +531 | +1x |
- character()+ C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint |
| 83 | -+ | |||
| 532 | +1x |
- } else {
+ D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint |
||
| 84 | -106x | +533 | +1x |
- unl+ E <- 1 + A * ((B + C) / D)^3 # nolint |
| 85 | -+ | |||
| 534 | +1x |
- }+ ci_upr <- 1 / E |
||
| 86 | -+ | |||
| 535 | +1x |
- }+ A <- (x / (n - x - 1))^2 # nolint |
||
| 87 | -+ | |||
| 536 | +1x |
-
+ B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint |
||
| 88 | -+ | |||
| 537 | +1x |
- #' Constructor for content functions given a data frame with flag input+ C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint |
||
| 89 | -+ | |||
| 538 | +1x |
- #'+ D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint |
||
| 90 | -+ | |||
| 539 | +1x |
- #' This can be useful for tabulating model results.+ E <- 1 + A * ((B + C) / D)^3 # nolint |
||
| 91 | -+ | |||
| 540 | +1x |
- #'+ ci_lwr <- 1 / E |
||
| 92 | +541 |
- #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the+ } |
||
| 93 | +542 |
- #' content function.+ }, |
||
| 94 | -+ | |||
| 543 | +26x |
- #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned.+ midp = {
|
||
| 95 | -+ | |||
| 544 | +1x |
- #' @param format (`string`)\cr `rtables` format to use.+ f_low <- function(pi, x, n) {
|
||
| 96 | -+ | |||
| 545 | +12x |
- #'+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x, |
||
| 97 | -+ | |||
| 546 | +12x |
- #' @return A content function which gives `df$analysis_var` at the row identified by+ size = n, prob = pi, lower.tail = FALSE |
||
| 98 | +547 |
- #' `.df_row$flag` in the given format.+ ) - |
||
| 99 | -+ | |||
| 548 | +12x |
- #'+ (1 - conf.level) / 2 |
||
| 100 | +549 |
- #' @keywords internal+ } |
||
| 101 | -+ | |||
| 550 | +1x |
- cfun_by_flag <- function(analysis_var,+ f_up <- function(pi, x, n) {
|
||
| 102 | -+ | |||
| 551 | +12x |
- flag_var,+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2 |
||
| 103 | +552 |
- format = "xx",+ } |
||
| 104 | -+ | |||
| 553 | +1x |
- .indent_mods = NULL) {
+ ci_lwr <- 0 |
||
| 105 | -61x | +554 | +1x |
- checkmate::assert_string(analysis_var)+ ci_upr <- 1 |
| 106 | -61x | +555 | +1x |
- checkmate::assert_string(flag_var)+ if (x != 0) {
|
| 107 | -61x | +556 | +1x |
- function(df, labelstr) {
+ ci_lwr <- stats::uniroot(f_low, |
| 108 | -265x | +557 | +1x |
- row_index <- which(df[[flag_var]])+ interval = c(0, p_hat), |
| 109 | -265x | +558 | +1x |
- x <- unlist_and_blank_na(df[[analysis_var]][row_index])+ x = x, n = n |
| 110 | -265x | +559 | +1x |
- formatters::with_label(+ )$root |
| 111 | -265x | +|||
| 560 | +
- rcell(x, format = format, indent_mod = .indent_mods),+ } |
|||
| 112 | -265x | +561 | +1x |
- labelstr+ if (x != n) {
|
| 113 | -+ | |||
| 562 | +1x |
- )+ ci_upr <- stats::uniroot(f_up, interval = c( |
||
| 114 | -+ | |||
| 563 | +1x |
- }+ p_hat, |
||
| 115 | -+ | |||
| 564 | +1x |
- }+ 1 |
||
| 116 | -+ | |||
| 565 | +1x |
-
+ ), x = x, n = n)$root |
||
| 117 | +566 |
- #' Content row function to add row total to labels+ } |
||
| 118 | +567 |
- #'+ }, |
||
| 119 | -+ | |||
| 568 | +26x |
- #' This takes the label of the latest row split level and adds the row total from `df` in parentheses.+ lik = {
|
||
| 120 | -+ | |||
| 569 | +2x |
- #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than+ ci_lwr <- 0 |
||
| 121 | -+ | |||
| 570 | +2x |
- #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`.+ ci_upr <- 1 |
||
| 122 | -+ | |||
| 571 | +2x |
- #'+ z <- stats::qnorm(1 - alpha * 0.5) |
||
| 123 | -+ | |||
| 572 | +2x |
- #' @inheritParams argument_convention+ tol <- .Machine$double.eps^0.5 |
||
| 124 | -+ | |||
| 573 | +2x |
- #'+ BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint |
||
| 125 | +574 |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ ...) {
|
||
| 126 | -+ | |||
| 575 | +40x |
- #'+ ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt, |
||
| 127 | -+ | |||
| 576 | +40x |
- #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because+ y, |
||
| 128 | -+ | |||
| 577 | +40x |
- #' the former is already split by columns and will refer to the first column of the data only.+ log = TRUE |
||
| 129 | +578 |
- #'+ )) |
||
| 130 | -+ | |||
| 579 | +40x |
- #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from+ ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x, |
||
| 131 | -+ | |||
| 580 | +40x |
- #' `alt_counts_df` instead of `df`.+ wt, mu, |
||
| 132 | -+ | |||
| 581 | +40x |
- #'+ log = TRUE |
||
| 133 | +582 |
- #' @keywords internal+ )) |
||
| 134 | -+ | |||
| 583 | +40x |
- c_label_n <- function(df,+ res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu))) |
||
| 135 | -+ | |||
| 584 | +40x |
- labelstr,+ return(res - bound) |
||
| 136 | +585 |
- .N_row) { # nolint
+ } |
||
| 137 | -273x | +586 | +2x |
- label <- paste0(labelstr, " (N=", .N_row, ")")+ if (x != 0 && tol < p_hat) {
|
| 138 | -273x | +587 | +2x |
- in_rows(+ ci_lwr <- if (BinDev( |
| 139 | -273x | +588 | +2x |
- .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)),+ tol, x, p_hat, n, -z, |
| 140 | -273x | +589 | +2x |
- .formats = c(row_count = function(x, ...) "")+ tol |
| 141 | -+ | |||
| 590 | +2x |
- )+ ) <= 0) {
|
||
| 142 | -+ | |||
| 591 | +2x |
- }+ stats::uniroot( |
||
| 143 | -+ | |||
| 592 | +2x |
-
+ f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) {
|
||
| 144 | -+ | |||
| 593 | +! |
- #' Content row function to add `alt_counts_df` row total to labels+ 1 - tol |
||
| 145 | +594 |
- #'+ } else {
|
||
| 146 | -+ | |||
| 595 | +2x |
- #' This takes the label of the latest row split level and adds the row total from `alt_counts_df`+ p_hat |
||
| 147 | -+ | |||
| 596 | +2x |
- #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df`+ }), bound = -z, |
||
| 148 | -+ | |||
| 597 | +2x |
- #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`.+ x = x, mu = p_hat, wt = n |
||
| 149 | -+ | |||
| 598 | +2x |
- #'+ )$root |
||
| 150 | +599 |
- #' @inheritParams argument_convention+ } |
||
| 151 | +600 |
- #'+ } |
||
| 152 | -+ | |||
| 601 | +2x |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ if (x != n && p_hat < (1 - tol)) {
|
||
| 153 | -+ | |||
| 602 | +2x |
- #'+ ci_upr <- if ( |
||
| 154 | -+ | |||
| 603 | +2x |
- #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead+ BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat > 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) < 0) { # nolint
|
||
| 155 | -+ | |||
| 604 | +! |
- #' of `alt_counts_df`.+ ci_lwr <- if (BinDev( |
||
| 156 | -+ | |||
| 605 | +! |
- #'+ tol, x, if (p_hat < tol || p_hat == 1) {
|
||
| 157 | -+ | |||
| 606 | +! |
- #' @keywords internal+ 1 - tol |
||
| 158 | +607 |
- c_label_n_alt <- function(df,+ } else {
|
||
| 159 | -+ | |||
| 608 | +! |
- labelstr,+ p_hat |
||
| 160 | -+ | |||
| 609 | +! |
- .alt_df_row) {
+ }, n, |
||
| 161 | -7x | +|||
| 610 | +! |
- N_row_alt <- nrow(.alt_df_row) # nolint+ -z, tol |
||
| 162 | -7x | +|||
| 611 | +! |
- label <- paste0(labelstr, " (N=", N_row_alt, ")")+ ) <= 0) {
|
||
| 163 | -7x | +|||
| 612 | +! |
- in_rows(+ stats::uniroot( |
||
| 164 | -7x | +|||
| 613 | +! |
- .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)),+ f = BinDev, interval = c(tol, p_hat), |
||
| 165 | -7x | +|||
| 614 | +! |
- .formats = c(row_count = function(x, ...) "")+ bound = -z, x = x, mu = p_hat, wt = n |
||
| 166 | -+ | |||
| 615 | +! |
- )+ )$root |
||
| 167 | +616 |
- }+ } |
||
| 168 | +617 |
-
+ } else {
|
||
| 169 | -+ | |||
| 618 | +2x |
- #' Layout-creating function to add row total counts+ stats::uniroot( |
||
| 170 | -+ | |||
| 619 | +2x |
- #'+ f = BinDev, interval = c(if (p_hat > 1 - tol) {
|
||
| 171 | -+ | |||
| 620 | +! |
- #' @description `r lifecycle::badge("stable")`
+ tol |
||
| 172 | +621 |
- #'+ } else {
|
||
| 173 | -+ | |||
| 622 | +2x |
- #' This works analogously to [rtables::add_colcounts()] but on the rows. This function+ p_hat |
||
| 174 | -+ | |||
| 623 | +2x |
- #' is a wrapper for [rtables::summarize_row_groups()].+ }, 1 - tol), bound = z, |
||
| 175 | -+ | |||
| 624 | +2x |
- #'+ x = x, mu = p_hat, wt = n |
||
| 176 | -+ | |||
| 625 | +2x |
- #' @inheritParams argument_convention+ )$root |
||
| 177 | +626 |
- #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`)+ } |
||
| 178 | +627 |
- #' or from `df` (`FALSE`). Defaults to `FALSE`.+ } |
||
| 179 | +628 |
- #'+ }, |
||
| 180 | -+ | |||
| 629 | +26x |
- #' @return A modified layout where the latest row split labels now have the row-wise+ blaker = {
|
||
| 181 | -+ | |||
| 630 | +1x |
- #' total counts (i.e. without column-based subsetting) attached in parentheses.+ acceptbin <- function(x, n, p) {
|
||
| 182 | -+ | |||
| 631 | +3954x |
- #'+ p1 <- 1 - stats::pbinom(x - 1, n, p) |
||
| 183 | -+ | |||
| 632 | +3954x |
- #' @note Row count values are contained in these row count rows but are not displayed+ p2 <- stats::pbinom(x, n, p) |
||
| 184 | -+ | |||
| 633 | +3954x |
- #' so that they are not considered zero rows by default when pruning.+ a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p) |
||
| 185 | -+ | |||
| 634 | +3954x |
- #'+ a2 <- p2 + 1 - stats::pbinom( |
||
| 186 | -+ | |||
| 635 | +3954x |
- #' @examples+ stats::qbinom(1 - p2, n, p), n, |
||
| 187 | -+ | |||
| 636 | +3954x |
- #' basic_table() %>%+ p |
||
| 188 | +637 |
- #' split_cols_by("ARM") %>%
+ ) |
||
| 189 | -+ | |||
| 638 | +3954x |
- #' add_colcounts() %>%+ return(min(a1, a2)) |
||
| 190 | +639 |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ } |
||
| 191 | -+ | |||
| 640 | +1x |
- #' add_rowcounts() %>%+ ci_lwr <- 0 |
||
| 192 | -+ | |||
| 641 | +1x |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ ci_upr <- 1 |
||
| 193 | -+ | |||
| 642 | +1x |
- #' build_table(DM)+ if (x != 0) {
|
||
| 194 | -+ | |||
| 643 | +1x |
- #'+ ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1)+ |
+ ||
| 644 | +1x | +
+ while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) {
+ |
+ ||
| 645 | +1976x | +
+ ci_lwr <- ci_lwr + tol |
||
| 195 | +646 |
- #' @export+ } |
||
| 196 | +647 |
- add_rowcounts <- function(lyt, alt_counts = FALSE) {
+ } |
||
| 197 | -7x | +648 | +1x |
- summarize_row_groups(+ if (x != n) {
|
| 198 | -7x | +649 | +1x |
- lyt,+ ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x) |
| 199 | -7x | +650 | +1x |
- cfun = if (alt_counts) c_label_n_alt else c_label_n+ while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) {
|
| 200 | -+ | |||
| 651 | +1976x |
- )+ ci_upr <- ci_upr - tol |
||
| 201 | +652 |
- }+ } |
||
| 202 | +653 |
-
+ } |
||
| 203 | +654 |
- #' Obtain column indices+ } |
||
| 204 | +655 |
- #'+ ) |
||
| 205 | -+ | |||
| 656 | +26x |
- #' @description `r lifecycle::badge("stable")`
+ ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min( |
||
| 206 | -+ | |||
| 657 | +26x |
- #'+ 1, |
||
| 207 | -+ | |||
| 658 | +26x |
- #' Helper function to extract column indices from a `VTableTree` for a given+ ci_upr |
||
| 208 | +659 |
- #' vector of column names.+ )) |
||
| 209 | -+ | |||
| 660 | +26x |
- #'+ if (sides == "left") {
|
||
| 210 | -+ | |||
| 661 | +1x |
- #' @param table_tree (`VTableTree`)\cr `rtables` table object to extract the indices from.+ ci[3] <- 1 |
||
| 211 | -+ | |||
| 662 | +25x |
- #' @param col_names (`character`)\cr vector of column names.+ } else if (sides == "right") {
|
||
| 212 | -+ | |||
| 663 | +! |
- #'+ ci[2] <- 0 |
||
| 213 | +664 |
- #' @return A vector of column indices.+ } |
||
| 214 | -+ | |||
| 665 | +26x |
- #'+ return(ci) |
||
| 215 | +666 |
- #' @export+ } |
||
| 216 | -+ | |||
| 667 | +26x |
- h_col_indices <- function(table_tree, col_names) {
+ lst <- list( |
||
| 217 | -1256x | +668 | +26x |
- checkmate::assert_class(table_tree, "VTableNodeInfo")+ x = x, n = n, conf.level = conf.level, sides = sides, |
| 218 | -1256x | +669 | +26x |
- checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE)+ method = method, rand = rand+ |
+
| 670 | ++ |
+ ) |
||
| 219 | -1256x | +671 | +26x |
- match(col_names, names(attr(col_info(table_tree), "cextra_args")))+ maxdim <- max(unlist(lapply(lst, length))) |
| 220 | -+ | |||
| 672 | +26x |
- }+ lgp <- lapply(lst, rep, length.out = maxdim) |
||
| 221 | -+ | |||
| 673 | +26x |
-
+ lgn <- h_recycle(x = if (is.null(names(x))) {
|
||
| 222 | -+ | |||
| 674 | +26x |
- #' Labels or names of list elements+ paste("x", seq_along(x), sep = ".")
|
||
| 223 | +675 |
- #'+ } else {
|
||
| 224 | -+ | |||
| 676 | +! |
- #' Internal helper function for working with nested statistic function results which typically+ names(x) |
||
| 225 | -+ | |||
| 677 | +26x |
- #' don't have labels but names that we can use.+ }, n = if (is.null(names(n))) {
|
||
| 226 | -+ | |||
| 678 | +26x |
- #'+ paste("n", seq_along(n), sep = ".")
|
||
| 227 | +679 |
- #' @param x (`list`)\cr a list.+ } else {
|
||
| 228 | -+ | |||
| 680 | +! |
- #'+ names(n) |
||
| 229 | -+ | |||
| 681 | +26x |
- #' @return A `character` vector with the labels or names for the list elements.+ }, conf.level = conf.level, sides = sides, method = method) |
||
| 230 | -+ | |||
| 682 | +26x |
- #'+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
||
| 231 | -+ | |||
| 683 | +130x |
- #' @keywords internal+ length(unique(x)) != |
||
| 232 | -+ | |||
| 684 | +130x |
- labels_or_names <- function(x) {
+ 1 |
||
| 233 | -190x | +685 | +26x |
- checkmate::assert_multi_class(x, c("data.frame", "list"))
+ })]), 1, paste, collapse = ":") |
| 234 | -190x | +686 | +26x |
- labs <- sapply(x, obj_label)+ res <- t(sapply(1:maxdim, function(i) {
|
| 235 | -190x | +687 | +26x |
- nams <- rlang::names2(x)+ iBinomCI( |
| 236 | -190x | +688 | +26x |
- label_is_null <- sapply(labs, is.null)+ x = lgp$x[i], |
| 237 | -190x | +689 | +26x |
- result <- unlist(ifelse(label_is_null, nams, labs))+ n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i], |
| 238 | -190x | +690 | +26x |
- return(result)+ method = lgp$method[i], rand = lgp$rand[i] |
| 239 | +691 |
- }+ ) |
||
| 240 | +692 |
-
+ })) |
||
| 241 | -+ | |||
| 693 | +26x |
- #' Convert to `rtable`+ colnames(res)[1] <- c("est")
+ |
+ ||
| 694 | +26x | +
+ rownames(res) <- xn+ |
+ ||
| 695 | +26x | +
+ return(res) |
||
| 242 | +696 |
- #'+ } |
| 243 | +1 |
- #' @description `r lifecycle::badge("stable")`
+ #' Tabulate survival duration by subgroup |
||
| 244 | +2 |
#' |
||
| 245 | +3 |
- #' This is a new generic function to convert objects to `rtable` tables.+ #' @description `r lifecycle::badge("stable")`
|
||
| 246 | +4 |
#' |
||
| 247 | +5 |
- #' @param x (`data.frame`)\cr the object which should be converted to an `rtable`.+ #' The [tabulate_survival_subgroups()] function creates a layout element to tabulate survival duration by subgroup, |
||
| 248 | +6 |
- #' @param ... additional arguments for methods.+ #' returning statistics including median survival time and hazard ratio for each population subgroup. The table is |
||
| 249 | +7 |
- #'+ #' created from `df`, a list of data frames returned by [extract_survival_subgroups()], with the statistics to include |
||
| 250 | +8 |
- #' @return An `rtables` table object. Note that the concrete class will depend on the method used.+ #' specified via the `vars` parameter. |
||
| 251 | +9 |
#' |
||
| 252 | +10 |
- #' @export+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 253 | +11 |
- as.rtable <- function(x, ...) { # nolint
+ #' |
||
| 254 | -3x | +|||
| 12 | +
- UseMethod("as.rtable", x)
+ #' @inheritParams argument_convention |
|||
| 255 | +13 |
- }+ #' @inheritParams survival_coxph_pairwise |
||
| 256 | +14 |
-
+ #' @param df (`list`)\cr list of data frames containing all analysis variables. List should be |
||
| 257 | +15 |
- #' @describeIn as.rtable Method for converting a `data.frame` that contains numeric columns to `rtable`.+ #' created using [extract_survival_subgroups()]. |
||
| 258 | +16 |
- #'+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 259 | +17 |
- #' @param format (`string` or `function`)\cr the format which should be used for the columns.+ #' * `n_tot_events`: Total number of events per group. |
||
| 260 | +18 |
- #'+ #' * `n_events`: Number of events per group. |
||
| 261 | +19 |
- #' @method as.rtable data.frame+ #' * `n_tot`: Total number of observations per group. |
||
| 262 | +20 |
- #'+ #' * `n`: Number of observations per group. |
||
| 263 | +21 |
- #' @examples+ #' * `median`: Median survival time. |
||
| 264 | +22 |
- #' x <- data.frame(+ #' * `hr`: Hazard ratio. |
||
| 265 | +23 |
- #' a = 1:10,+ #' * `ci`: Confidence interval of hazard ratio. |
||
| 266 | +24 |
- #' b = rnorm(10)+ #' * `pval`: p-value of the effect. |
||
| 267 | +25 |
- #' )+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` |
||
| 268 | +26 |
- #' as.rtable(x)+ #' are required. |
||
| 269 | +27 |
- #'+ #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit. |
||
| 270 | +28 |
- #' @export+ #' |
||
| 271 | +29 |
- as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
+ #' @details These functions create a layout starting from a data frame which contains |
||
| 272 | -3x | +|||
| 30 | +
- checkmate::assert_numeric(unlist(x))+ #' the required statistics. Tables typically used as part of forest plot. |
|||
| 273 | -2x | +|||
| 31 | +
- do.call(+ #' |
|||
| 274 | -2x | +|||
| 32 | +
- rtable,+ #' @seealso [extract_survival_subgroups()] |
|||
| 275 | -2x | +|||
| 33 | +
- c(+ #' |
|||
| 276 | -2x | +|||
| 34 | +
- list(+ #' @examples |
|||
| 277 | -2x | +|||
| 35 | +
- header = labels_or_names(x),+ #' library(dplyr) |
|||
| 278 | -2x | +|||
| 36 | +
- format = format+ #' |
|||
| 279 | +37 |
- ),+ #' adtte <- tern_ex_adtte |
||
| 280 | -2x | +|||
| 38 | +
- Map(+ #' |
|||
| 281 | -2x | +|||
| 39 | +
- function(row, row_name) {
+ #' # Save variable labels before data processing steps. |
|||
| 282 | -20x | +|||
| 40 | +
- do.call(+ #' adtte_labels <- formatters::var_labels(adtte) |
|||
| 283 | -20x | +|||
| 41 | +
- rrow,+ #' |
|||
| 284 | -20x | +|||
| 42 | +
- c(as.list(unname(row)),+ #' adtte_f <- adtte %>% |
|||
| 285 | -20x | +|||
| 43 | +
- row.name = row_name+ #' filter( |
|||
| 286 | +44 |
- )+ #' PARAMCD == "OS", |
||
| 287 | +45 |
- )+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 288 | +46 |
- },+ #' SEX %in% c("M", "F")
|
||
| 289 | -2x | +|||
| 47 | +
- row = as.data.frame(t(x)),+ #' ) %>% |
|||
| 290 | -2x | +|||
| 48 | +
- row_name = rownames(x)+ #' mutate( |
|||
| 291 | +49 |
- )+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 292 | +50 |
- )+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 293 | +51 |
- )+ #' SEX = droplevels(SEX), |
||
| 294 | +52 |
- }+ #' AVALU = as.character(AVALU), |
||
| 295 | +53 |
-
+ #' is_event = CNSR == 0 |
||
| 296 | +54 |
- #' Split parameters+ #' ) |
||
| 297 | +55 |
- #'+ #' labels <- c( |
||
| 298 | +56 |
- #' @description `r lifecycle::badge("stable")`
+ #' "ARM" = adtte_labels[["ARM"]], |
||
| 299 | +57 |
- #'+ #' "SEX" = adtte_labels[["SEX"]], |
||
| 300 | +58 |
- #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant+ #' "AVALU" = adtte_labels[["AVALU"]], |
||
| 301 | +59 |
- #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to+ #' "is_event" = "Event Flag" |
||
| 302 | +60 |
- #' specific analysis function.+ #' ) |
||
| 303 | +61 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 304 | +62 |
- #' @param param (`vector`)\cr the parameter to be split.+ #' |
||
| 305 | +63 |
- #' @param value (`vector`)\cr the value used to split.+ #' df <- extract_survival_subgroups( |
||
| 306 | +64 |
- #' @param f (`list`)\cr the reference to make the split.+ #' variables = list( |
||
| 307 | +65 |
- #'+ #' tte = "AVAL", |
||
| 308 | +66 |
- #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`.+ #' is_event = "is_event", |
||
| 309 | +67 |
- #'+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 310 | +68 |
- #' @examples+ #' ), |
||
| 311 | +69 |
- #' f <- list(+ #' label_all = "Total Patients", |
||
| 312 | +70 |
- #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ #' data = adtte_f |
||
| 313 | +71 |
- #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ #' ) |
||
| 314 | +72 |
- #' )+ #' df |
||
| 315 | +73 |
#' |
||
| 316 | +74 |
- #' .stats <- c("pt_at_risk", "rate_diff")
+ #' df_grouped <- extract_survival_subgroups( |
||
| 317 | +75 |
- #' h_split_param(.stats, .stats, f = f)+ #' variables = list( |
||
| 318 | +76 |
- #'+ #' tte = "AVAL", |
||
| 319 | +77 |
- #' # $surv+ #' is_event = "is_event", |
||
| 320 | +78 |
- #' # [1] "pt_at_risk"+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 321 | +79 |
- #' #+ #' ), |
||
| 322 | +80 |
- #' # $surv_diff+ #' data = adtte_f, |
||
| 323 | +81 |
- #' # [1] "rate_diff"+ #' groups_lists = list( |
||
| 324 | +82 |
- #'+ #' BMRKR2 = list( |
||
| 325 | +83 |
- #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
+ #' "low" = "LOW", |
||
| 326 | +84 |
- #' h_split_param(.formats, names(.formats), f = f)+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 327 | +85 |
- #'+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 328 | +86 |
- #' # $surv+ #' ) |
||
| 329 | +87 |
- #' # pt_at_risk event_free_rate+ #' ) |
||
| 330 | +88 |
- #' # "xx" "xxx"+ #' ) |
||
| 331 | +89 |
- #' #+ #' df_grouped |
||
| 332 | +90 |
- #' # $surv_diff+ #' |
||
| 333 | +91 |
- #' # NULL+ #' @name survival_duration_subgroups |
||
| 334 | +92 |
- #'+ #' @order 1 |
||
| 335 | +93 |
- #' @export+ NULL |
||
| 336 | +94 |
- h_split_param <- function(param,+ |
||
| 337 | +95 |
- value,+ #' Prepare survival data for population subgroups in data frames |
||
| 338 | +96 |
- f) {
+ #' |
||
| 339 | -26x | +|||
| 97 | +
- y <- lapply(f, function(x) param[value %in% x])+ #' @description `r lifecycle::badge("stable")`
|
|||
| 340 | -26x | +|||
| 98 | +
- lapply(y, function(x) if (length(x) == 0) NULL else x)+ #' |
|||
| 341 | +99 |
- }+ #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in |
||
| 342 | +100 |
-
+ #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list` |
||
| 343 | +101 |
- #' Get selected statistics names+ #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`, |
||
| 344 | +102 |
- #'+ #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`. |
||
| 345 | +103 |
- #' Helper function to be used for creating `afun`.+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 346 | +104 |
#' |
||
| 347 | +105 |
- #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means+ #' @inheritParams argument_convention |
||
| 348 | +106 |
- #' in this context that all default statistics should be used.+ #' @inheritParams survival_duration_subgroups |
||
| 349 | +107 |
- #' @param all_stats (`character`)\cr all statistics which can be selected here potentially.+ #' @inheritParams survival_coxph_pairwise |
||
| 350 | +108 |
#' |
||
| 351 | +109 |
- #' @return A `character` vector with the selected statistics.+ #' @return A named `list` of two elements: |
||
| 352 | +110 |
- #'+ #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`, |
||
| 353 | +111 |
- #' @keywords internal+ #' `var_label`, and `row_type`. |
||
| 354 | +112 |
- afun_selected_stats <- function(.stats, all_stats) {
+ #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`, |
||
| 355 | -2x | +|||
| 113 | +
- checkmate::assert_character(.stats, null.ok = TRUE)+ #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
|||
| 356 | -2x | +|||
| 114 | +
- checkmate::assert_character(all_stats)+ #' |
|||
| 357 | -2x | +|||
| 115 | +
- if (is.null(.stats)) {
+ #' @seealso [survival_duration_subgroups] |
|||
| 358 | -1x | +|||
| 116 | +
- all_stats+ #' |
|||
| 359 | +117 |
- } else {
+ #' @export |
||
| 360 | -1x | +|||
| 118 | +
- intersect(.stats, all_stats)+ extract_survival_subgroups <- function(variables, |
|||
| 361 | +119 |
- }+ data, |
||
| 362 | +120 |
- }+ groups_lists = list(), |
||
| 363 | +121 |
-
+ control = control_coxph(), |
||
| 364 | +122 |
- #' Add variable labels to top left corner in table+ label_all = "All Patients") {
|
||
| 365 | -+ | |||
| 123 | +12x |
- #'+ if ("strat" %in% names(variables)) {
|
||
| 366 | -+ | |||
| 124 | +! |
- #' @description `r lifecycle::badge("stable")`
+ warning( |
||
| 367 | -+ | |||
| 125 | +! |
- #'+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ", |
||
| 368 | -+ | |||
| 126 | +! |
- #' Helper layout-creating function to append the variable labels of a given variables vector+ "was deprecated in tern 0.9.4.\n ", |
||
| 369 | -+ | |||
| 127 | +! |
- #' from a given dataset in the top left corner. If a variable label is not found then the+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 370 | +128 |
- #' variable name itself is used instead. Multiple variable labels are concatenated with slashes.+ ) |
||
| 371 | -+ | |||
| 129 | +! |
- #'+ variables[["strata"]] <- variables[["strat"]] |
||
| 372 | +130 |
- #' @inheritParams argument_convention+ } |
||
| 373 | +131 |
- #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.+ |
||
| 374 | -+ | |||
| 132 | +12x |
- #' @param indent (`integer(1)`)\cr non-negative number of nested indent space, default to 0L which means no indent.+ df_survtime <- h_survtime_subgroups_df( |
||
| 375 | -+ | |||
| 133 | +12x |
- #' 1L means two spaces indent, 2L means four spaces indent and so on.+ variables, |
||
| 376 | -+ | |||
| 134 | +12x |
- #'+ data, |
||
| 377 | -+ | |||
| 135 | +12x |
- #' @return A modified layout with the new variable label(s) added to the top-left material.+ groups_lists = groups_lists, |
||
| 378 | -+ | |||
| 136 | +12x |
- #'+ label_all = label_all |
||
| 379 | +137 |
- #' @note This is not an optimal implementation of course, since we are using here the data set+ )+ |
+ ||
| 138 | +12x | +
+ df_hr <- h_coxph_subgroups_df(+ |
+ ||
| 139 | +12x | +
+ variables,+ |
+ ||
| 140 | +12x | +
+ data,+ |
+ ||
| 141 | +12x | +
+ groups_lists = groups_lists,+ |
+ ||
| 142 | +12x | +
+ control = control,+ |
+ ||
| 143 | +12x | +
+ label_all = label_all |
||
| 380 | +144 |
- #' itself during the layout creation. When we have a more mature `rtables` implementation then+ ) |
||
| 381 | +145 |
- #' this will also be improved or not necessary anymore.+ + |
+ ||
| 146 | +12x | +
+ list(survtime = df_survtime, hr = df_hr) |
||
| 382 | +147 |
- #'+ } |
||
| 383 | +148 |
- #' @examples+ |
||
| 384 | +149 |
- #' lyt <- basic_table() %>%+ #' @describeIn survival_duration_subgroups Formatted analysis function which is used as |
||
| 385 | +150 |
- #' split_cols_by("ARM") %>%
+ #' `afun` in `tabulate_survival_subgroups()`. |
||
| 386 | +151 |
- #' add_colcounts() %>%+ #' |
||
| 387 | +152 |
- #' split_rows_by("SEX") %>%
+ #' @return |
||
| 388 | +153 |
- #' append_varlabels(DM, "SEX") %>%+ #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 389 | +154 |
- #' analyze("AGE", afun = mean) %>%
+ #' |
||
| 390 | +155 |
- #' append_varlabels(DM, "AGE", indent = 1)+ #' @keywords internal |
||
| 391 | +156 |
- #' build_table(lyt, DM)+ a_survival_subgroups <- function(.formats = list( # nolint start |
||
| 392 | +157 |
- #'+ n = "xx", |
||
| 393 | +158 |
- #' lyt <- basic_table() %>%+ n_events = "xx", |
||
| 394 | +159 |
- #' split_cols_by("ARM") %>%
+ n_tot_events = "xx", |
||
| 395 | +160 |
- #' split_rows_by("SEX") %>%
+ median = "xx.x", |
||
| 396 | +161 |
- #' analyze("AGE", afun = mean) %>%
+ n_tot = "xx", |
||
| 397 | +162 |
- #' append_varlabels(DM, c("SEX", "AGE"))
+ hr = list(format_extreme_values(2L)), |
||
| 398 | +163 |
- #' build_table(lyt, DM)+ ci = list(format_extreme_values_ci(2L)), |
||
| 399 | +164 |
- #'+ pval = "x.xxxx | (<0.0001)" |
||
| 400 | +165 |
- #' @export+ ), |
||
| 401 | +166 |
- append_varlabels <- function(lyt, df, vars, indent = 0L) {
+ na_str = default_na_str()) { # nolint end
|
||
| 402 | -3x | +167 | +21x |
- if (checkmate::test_flag(indent)) {
+ checkmate::assert_list(.formats) |
| 403 | -! | +|||
| 168 | +21x |
- warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
+ checkmate::assert_subset( |
||
| 404 | -! | +|||
| 169 | +21x |
- indent <- as.integer(indent)+ names(.formats),+ |
+ ||
| 170 | +21x | +
+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval", "riskdiff")
|
||
| 405 | +171 |
- }+ ) |
||
| 406 | +172 | |||
| 407 | -3x | +173 | +21x |
- checkmate::assert_data_frame(df)+ afun_lst <- Map( |
| 408 | -3x | +174 | +21x |
- checkmate::assert_character(vars)+ function(stat, fmt, na_str) {
|
| 409 | -3x | +175 | +160x |
- checkmate::assert_count(indent)+ function(df, labelstr = "", ...) {
|
| 410 | -+ | |||
| 176 | +312x |
-
+ in_rows( |
||
| 411 | -3x | +177 | +312x |
- lab <- formatters::var_labels(df[vars], fill = TRUE)+ .list = as.list(df[[stat]]), |
| 412 | -3x | +178 | +312x |
- lab <- paste(lab, collapse = " / ")+ .labels = as.character(df$subgroup), |
| 413 | -3x | +179 | +312x |
- space <- paste(rep(" ", indent * 2), collapse = "")
+ .formats = fmt, |
| 414 | -3x | +180 | +312x |
- lab <- paste0(space, lab)+ .format_na_strs = na_str |
| 415 | +181 |
-
+ ) |
||
| 416 | -3x | +|||
| 182 | +
- append_topleft(lyt, lab)+ } |
|||
| 417 | +183 |
- }+ }, |
||
| 418 | -+ | |||
| 184 | +21x |
-
+ stat = names(.formats), |
||
| 419 | -+ | |||
| 185 | +21x |
- #' Default string replacement for `NA` values+ fmt = .formats, |
||
| 420 | -+ | |||
| 186 | +21x |
- #'+ na_str = na_str |
||
| 421 | +187 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 422 | +188 |
- #'+ + |
+ ||
| 189 | +21x | +
+ afun_lst |
||
| 423 | +190 |
- #' The default string used to represent `NA` values. This value is used as the default+ } |
||
| 424 | +191 |
- #' value for the `na_str` argument throughout the `tern` package, and printed in place+ |
||
| 425 | +192 |
- #' of `NA` values in output tables. If not specified for each `tern` function by the user+ #' @describeIn survival_duration_subgroups Table-creating function which creates a table |
||
| 426 | +193 |
- #' via the `na_str` argument, or in the R environment options via [set_default_na_str()],+ #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
||
| 427 | +194 |
- #' then `NA` is used.+ #' and [rtables::summarize_row_groups()]. |
||
| 428 | +195 |
#' |
||
| 429 | +196 |
- #' @param na_str (`string`)\cr single string value to set in the R environment options as+ #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
|
||
| 430 | +197 |
- #' the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the
+ #' [extract_survival_subgroups()] function when creating `df`. |
||
| 431 | +198 |
- #' current value set in the R environment (defaults to `NULL` if not set).+ #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
||
| 432 | +199 |
- #'+ #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
||
| 433 | +200 |
- #' @name default_na_str+ #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$survtime$arm` will be used as `arm_x` |
||
| 434 | +201 |
- NULL+ #' and the second level as `arm_y`. |
||
| 435 | +202 |
-
+ #' |
||
| 436 | +203 |
- #' @describeIn default_na_str Accessor for default `NA` value replacement string.+ #' @return An `rtables` table summarizing survival by subgroup. |
||
| 437 | +204 |
#' |
||
| 438 | +205 |
- #' @return+ #' @examples |
||
| 439 | +206 |
- #' * `default_na_str` returns the current value if an R environment option has been set+ #' ## Table with default columns. |
||
| 440 | +207 |
- #' for `"tern_default_na_str"`, or `NA_character_` otherwise.+ #' basic_table() %>% |
||
| 441 | +208 |
- #'+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
||
| 442 | +209 |
- #' @examples+ #' |
||
| 443 | +210 |
- #' # Default settings+ #' ## Table with a manually chosen set of columns: adding "pval". |
||
| 444 | +211 |
- #' default_na_str()+ #' basic_table() %>% |
||
| 445 | +212 |
- #' getOption("tern_default_na_str")
+ #' tabulate_survival_subgroups( |
||
| 446 | +213 |
- #'+ #' df = df, |
||
| 447 | +214 |
- #' # Set custom value+ #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
|
||
| 448 | +215 |
- #' set_default_na_str("<Missing>")
+ #' time_unit = adtte_f$AVALU[1] |
||
| 449 | +216 |
- #'+ #' ) |
||
| 450 | +217 |
- #' # Settings after value has been set+ #' |
||
| 451 | +218 |
- #' default_na_str()+ #' @export |
||
| 452 | +219 |
- #' getOption("tern_default_na_str")
+ #' @order 2 |
||
| 453 | +220 |
- #'+ tabulate_survival_subgroups <- function(lyt, |
||
| 454 | +221 |
- #' @export+ df, |
||
| 455 | +222 |
- default_na_str <- function() {
- |
- ||
| 456 | -319x | -
- getOption("tern_default_na_str", default = NA_character_)
+ vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
|
||
| 457 | +223 |
- }+ groups_lists = list(), |
||
| 458 | +224 |
-
+ label_all = lifecycle::deprecated(), |
||
| 459 | +225 |
- #' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the+ time_unit = NULL, |
||
| 460 | +226 |
- #' option `"tern_default_na_str"` within the R environment.+ riskdiff = NULL, |
||
| 461 | +227 |
- #'+ na_str = default_na_str(), |
||
| 462 | +228 |
- #' @return+ .formats = c( |
||
| 463 | +229 |
- #' * `set_default_na_str` has no return value.+ n = "xx", n_events = "xx", n_tot_events = "xx", median = "xx.x", n_tot = "xx", |
||
| 464 | +230 |
- #'+ hr = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)), |
||
| 465 | +231 |
- #' @export+ pval = "x.xxxx | (<0.0001)" |
||
| 466 | +232 |
- set_default_na_str <- function(na_str) {
+ )) {
|
||
| 467 | -3x | +233 | +10x |
- checkmate::assert_character(na_str, len = 1, null.ok = TRUE)+ checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 468 | -3x | +234 | +10x |
- options("tern_default_na_str" = na_str)
+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
|
| 469 | -+ | |||
| 235 | +10x |
- }+ checkmate::assert_true(all(c("hr", "ci") %in% vars))
|
| 1 | +236 |
- #' Control function for Cox-PH model+ |
||
| 2 | -+ | |||
| 237 | +10x |
- #'+ if (lifecycle::is_present(label_all)) {
|
||
| 3 | -+ | |||
| 238 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ lifecycle::deprecate_warn( |
||
| 4 | -+ | |||
| 239 | +1x |
- #'+ "0.9.5", "tabulate_survival_subgroups(label_all)", |
||
| 5 | -+ | |||
| 240 | +1x |
- #' This is an auxiliary function for controlling arguments for Cox-PH model, typically used internally to specify+ details = |
||
| 6 | -+ | |||
| 241 | +1x |
- #' details of Cox-PH model for [s_coxph_pairwise()]. `conf_level` refers to Hazard Ratio estimation.+ "Please assign the `label_all` parameter within the `extract_survival_subgroups()` function when creating `df`." |
||
| 7 | +242 |
- #'+ ) |
||
| 8 | +243 |
- #' @inheritParams argument_convention+ } |
||
| 9 | +244 |
- #' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1.+ |
||
| 10 | +245 |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ # Create "ci" column from "lcl" and "ucl" |
||
| 11 | -+ | |||
| 246 | +10x |
- #' @param ties (`string`)\cr string specifying the method for tie handling. Default is `"efron"`,+ df$hr$ci <- combine_vectors(df$hr$lcl, df$hr$ucl) |
||
| 12 | +247 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()].+ |
||
| 13 | +248 |
- #'+ # Fill in missing formats with defaults |
||
| 14 | -+ | |||
| 249 | +10x |
- #' @return A list of components with the same names as the arguments.+ default_fmts <- eval(formals(tabulate_survival_subgroups)$.formats) |
||
| 15 | -+ | |||
| 250 | +10x |
- #'+ .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]]) |
||
| 16 | +251 |
- #' @export+ |
||
| 17 | +252 |
- control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
+ # Extract additional parameters from df |
||
| 18 | -+ | |||
| 253 | +10x |
- ties = c("efron", "breslow", "exact"),
+ conf_level <- df$hr$conf_level[1] |
||
| 19 | -+ | |||
| 254 | +10x |
- conf_level = 0.95) {
+ method <- df$hr$pval_label[1] |
||
| 20 | -52x | +255 | +10x |
- pval_method <- match.arg(pval_method)+ colvars <- d_survival_subgroups_colvars(vars, conf_level = conf_level, method = method, time_unit = time_unit) |
| 21 | -51x | +256 | +10x |
- ties <- match.arg(ties)+ survtime_vars <- intersect(colvars$vars, c("n", "n_events", "median"))
|
| 22 | -51x | +257 | +10x |
- assert_proportion_value(conf_level)+ hr_vars <- intersect(names(colvars$labels), c("n_tot", "n_tot_events", "hr", "ci", "pval"))
|
| 23 | -+ | |||
| 258 | +10x |
-
+ colvars_survtime <- list(vars = survtime_vars, labels = colvars$labels[survtime_vars]) |
||
| 24 | -50x | +259 | +10x |
- list(pval_method = pval_method, ties = ties, conf_level = conf_level)+ colvars_hr <- list(vars = hr_vars, labels = colvars$labels[hr_vars]) |
| 25 | +260 |
- }+ + |
+ ||
| 261 | +10x | +
+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method) |
||
| 26 | +262 | |||
| 27 | +263 |
- #' Control function for `survfit` models for survival time+ # Get analysis function for each statistic |
||
| 28 | -+ | |||
| 264 | +10x |
- #'+ afun_lst <- a_survival_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str) |
||
| 29 | +265 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 30 | +266 |
- #'+ # Add risk difference column |
||
| 31 | -+ | |||
| 267 | +10x |
- #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ if (!is.null(riskdiff)) {
|
||
| 32 | -+ | |||
| 268 | +1x |
- #' details of `survfit` model for [s_surv_time()]. `conf_level` refers to survival time estimation.+ if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$survtime$arm)[1] |
||
| 33 | -+ | |||
| 269 | +1x |
- #'+ if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$survtime$arm)[2] |
||
| 34 | -+ | |||
| 270 | +1x |
- #' @inheritParams argument_convention+ colvars_hr$vars <- c(colvars_hr$vars, "riskdiff") |
||
| 35 | -+ | |||
| 271 | +1x |
- #' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ colvars_hr$labels <- c(colvars_hr$labels, riskdiff = riskdiff$col_label) |
||
| 36 | -+ | |||
| 272 | +1x |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ arm_cols <- paste(rep(c("n_events", "n_events", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
|
||
| 37 | +273 |
- #' @param quantiles (`numeric(2)`)\cr vector of length two specifying the quantiles of survival time.+ |
||
| 38 | -+ | |||
| 274 | +1x |
- #'+ df_prop_diff <- df$survtime %>% |
||
| 39 | -+ | |||
| 275 | +1x |
- #' @return A list of components with the same names as the arguments.+ dplyr::select(-"median") %>% |
||
| 40 | -+ | |||
| 276 | +1x |
- #'+ tidyr::pivot_wider( |
||
| 41 | -+ | |||
| 277 | +1x |
- #' @export+ id_cols = c("subgroup", "var", "var_label", "row_type"),
|
||
| 42 | -+ | |||
| 278 | +1x |
- control_surv_time <- function(conf_level = 0.95,+ names_from = "arm", |
||
| 43 | -+ | |||
| 279 | +1x |
- conf_type = c("plain", "log", "log-log"),
+ values_from = c("n", "n_events")
|
||
| 44 | +280 |
- quantiles = c(0.25, 0.75)) {
+ ) %>% |
||
| 45 | -229x | +281 | +1x |
- conf_type <- match.arg(conf_type)+ dplyr::rowwise() %>% |
| 46 | -228x | +282 | +1x |
- checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE)+ dplyr::mutate( |
| 47 | -227x | +283 | +1x |
- nullo <- lapply(quantiles, assert_proportion_value)+ riskdiff = stat_propdiff_ci( |
| 48 | -227x | +284 | +1x |
- assert_proportion_value(conf_level)+ x = as.list(.data[[arm_cols[1]]]), |
| 49 | -226x | +285 | +1x |
- list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles)+ y = as.list(.data[[arm_cols[2]]]), |
| 50 | -+ | |||
| 286 | +1x |
- }+ N_x = .data[[arm_cols[3]]], |
||
| 51 | -+ | |||
| 287 | +1x |
-
+ N_y = .data[[arm_cols[4]]] |
||
| 52 | +288 |
- #' Control function for `survfit` models for patients' survival rate at time points+ ) |
||
| 53 | +289 |
- #'+ ) %>% |
||
| 54 | -+ | |||
| 290 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ dplyr::select(-dplyr::all_of(arm_cols)) |
||
| 55 | +291 |
- #'+ |
||
| 56 | -+ | |||
| 292 | +1x |
- #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ df$hr <- df$hr %>% |
||
| 57 | -+ | |||
| 293 | +1x |
- #' details of `survfit` model for [s_surv_timepoint()]. `conf_level` refers to patient risk estimation at a time point.+ dplyr::left_join( |
||
| 58 | -+ | |||
| 294 | +1x |
- #'+ df_prop_diff, |
||
| 59 | -+ | |||
| 295 | +1x |
- #' @inheritParams argument_convention+ by = c("subgroup", "var", "var_label", "row_type")
|
||
| 60 | +296 |
- #' @inheritParams control_surv_time+ ) |
||
| 61 | +297 |
- #'+ } |
||
| 62 | +298 |
- #' @return A list of components with the same names as the arguments.+ |
||
| 63 | +299 |
- #'+ # Add columns from table_survtime (optional)+ |
+ ||
| 300 | +10x | +
+ if (length(colvars_survtime$vars) > 0) {
+ |
+ ||
| 301 | +9x | +
+ lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")+ |
+ ||
| 302 | +9x | +
+ lyt_survtime <- split_rows_by(+ |
+ ||
| 303 | +9x | +
+ lyt = lyt_survtime,+ |
+ ||
| 304 | +9x | +
+ var = "row_type",+ |
+ ||
| 305 | +9x | +
+ split_fun = keep_split_levels("content"),
+ |
+ ||
| 306 | +9x | +
+ nested = FALSE |
||
| 64 | +307 |
- #' @export+ ) |
||
| 65 | +308 |
- control_surv_timepoint <- function(conf_level = 0.95,+ |
||
| 66 | +309 |
- conf_type = c("plain", "log", "log-log")) {
+ # Add "All Patients" row |
||
| 67 | -24x | +310 | +9x |
- conf_type <- match.arg(conf_type)+ lyt_survtime <- summarize_row_groups( |
| 68 | -23x | +311 | +9x |
- assert_proportion_value(conf_level)+ lyt = lyt_survtime, |
| 69 | -22x | +312 | +9x |
- list(+ var = "var_label", |
| 70 | -22x | +313 | +9x |
- conf_level = conf_level,+ cfun = afun_lst[names(colvars_survtime$labels)], |
| 71 | -22x | +314 | +9x |
- conf_type = conf_type+ na_str = na_str, |
| 72 | -+ | |||
| 315 | +9x |
- )+ extra_args = extra_args |
||
| 73 | +316 |
- }+ ) |
| 1 | -+ | |||
| 317 | +9x |
- #' Split function to configure risk difference column+ lyt_survtime <- split_cols_by_multivar( |
||
| 2 | -+ | |||
| 318 | +9x |
- #'+ lyt = lyt_survtime, |
||
| 3 | -+ | |||
| 319 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ vars = colvars_survtime$vars, |
||
| 4 | -+ | |||
| 320 | +9x |
- #'+ varlabels = colvars_survtime$labels |
||
| 5 | +321 |
- #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference+ ) |
||
| 6 | +322 |
- #' column to be added to an `rtables` object. To add a risk difference column to a table, this function+ |
||
| 7 | +323 |
- #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument+ # Add analysis rows |
||
| 8 | -+ | |||
| 324 | +9x |
- #' `riskdiff` to `TRUE` in all following analyze function calls.+ if ("analysis" %in% df$survtime$row_type) {
|
||
| 9 | -+ | |||
| 325 | +8x |
- #'+ lyt_survtime <- split_rows_by( |
||
| 10 | -+ | |||
| 326 | +8x |
- #' @param arm_x (`string`)\cr name of reference arm to use in risk difference calculations.+ lyt = lyt_survtime, |
||
| 11 | -+ | |||
| 327 | +8x |
- #' @param arm_y (`character`)\cr names of one or more arms to compare to reference arm in risk difference+ var = "row_type", |
||
| 12 | -+ | |||
| 328 | +8x |
- #' calculations. A new column will be added for each value of `arm_y`.+ split_fun = keep_split_levels("analysis"),
|
||
| 13 | -+ | |||
| 329 | +8x |
- #' @param col_label (`character`)\cr labels to use when rendering the risk difference column within the table.+ nested = FALSE, |
||
| 14 | -+ | |||
| 330 | +8x |
- #' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are+ child_labels = "hidden" |
||
| 15 | +331 |
- #' being compared (reference arm vs. comparison arm).+ ) |
||
| 16 | -+ | |||
| 332 | +8x |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE) |
||
| 17 | -+ | |||
| 333 | +8x |
- #'+ lyt_survtime <- analyze_colvars( |
||
| 18 | -+ | |||
| 334 | +8x |
- #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()]+ lyt = lyt_survtime, |
||
| 19 | -+ | |||
| 335 | +8x |
- #' when creating a table layout.+ afun = afun_lst[names(colvars_survtime$labels)], |
||
| 20 | -+ | |||
| 336 | +8x |
- #'+ na_str = na_str, |
||
| 21 | -+ | |||
| 337 | +8x |
- #' @seealso [stat_propdiff_ci()] for details on risk difference calculation.+ inclNAs = TRUE, |
||
| 22 | -+ | |||
| 338 | +8x |
- #'+ extra_args = extra_args |
||
| 23 | +339 |
- #' @examples+ ) |
||
| 24 | +340 |
- #' adae <- tern_ex_adae+ } |
||
| 25 | +341 |
- #' adae$AESEV <- factor(adae$AESEV)+ |
||
| 26 | -+ | |||
| 342 | +9x |
- #'+ table_survtime <- build_table(lyt_survtime, df = df$survtime) |
||
| 27 | +343 |
- #' lyt <- basic_table() %>%+ } else {
|
||
| 28 | -+ | |||
| 344 | +1x |
- #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
+ table_survtime <- NULL |
||
| 29 | +345 |
- #' count_occurrences_by_grade(+ } |
||
| 30 | +346 |
- #' var = "AESEV",+ |
||
| 31 | +347 |
- #' riskdiff = TRUE+ # Add columns from table_hr ("n_tot_events" or "n_tot", "or" and "ci" required)
|
||
| 32 | -+ | |||
| 348 | +10x |
- #' )+ lyt_hr <- split_cols_by(lyt = lyt, var = "arm") |
||
| 33 | -+ | |||
| 349 | +10x |
- #'+ lyt_hr <- split_rows_by( |
||
| 34 | -+ | |||
| 350 | +10x |
- #' tbl <- build_table(lyt, df = adae)+ lyt = lyt_hr, |
||
| 35 | -+ | |||
| 351 | +10x |
- #' tbl+ var = "row_type", |
||
| 36 | -+ | |||
| 352 | +10x |
- #'+ split_fun = keep_split_levels("content"),
|
||
| 37 | -+ | |||
| 353 | +10x |
- #' @export+ nested = FALSE |
||
| 38 | +354 |
- add_riskdiff <- function(arm_x,+ ) |
||
| 39 | -+ | |||
| 355 | +10x |
- arm_y,+ lyt_hr <- summarize_row_groups( |
||
| 40 | -+ | |||
| 356 | +10x |
- col_label = paste0(+ lyt = lyt_hr, |
||
| 41 | -+ | |||
| 357 | +10x |
- "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
+ var = "var_label", |
||
| 42 | -+ | |||
| 358 | +10x |
- ),+ cfun = afun_lst[names(colvars_hr$labels)],+ |
+ ||
| 359 | +10x | +
+ na_str = na_str,+ |
+ ||
| 360 | +10x | +
+ extra_args = extra_args |
||
| 43 | +361 |
- pct = TRUE) {
+ ) |
||
| 44 | -19x | +362 | +10x |
- checkmate::assert_character(arm_x, len = 1)+ lyt_hr <- split_cols_by_multivar( |
| 45 | -19x | +363 | +10x |
- checkmate::assert_character(arm_y, min.len = 1)+ lyt = lyt_hr, |
| 46 | -19x | +364 | +10x |
- checkmate::assert_character(col_label, len = length(arm_y))+ vars = colvars_hr$vars,+ |
+
| 365 | +10x | +
+ varlabels = colvars_hr$labels |
||
| 47 | +366 |
-
+ ) %>% |
||
| 48 | -19x | +367 | +10x |
- combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs)+ append_topleft("Baseline Risk Factors")
+ |
+
| 368 | ++ | + + | +||
| 369 | ++ |
+ # Add analysis rows |
||
| 49 | -19x | +370 | +10x |
- for (i in seq_len(length(arm_y))) {
+ if ("analysis" %in% df$survtime$row_type) {
|
| 50 | -20x | +371 | +9x |
- combodf <- rbind(+ lyt_hr <- split_rows_by( |
| 51 | -20x | +372 | +9x |
- combodf,+ lyt = lyt_hr, |
| 52 | -20x | +373 | +9x |
- tibble::tribble(+ var = "row_type", |
| 53 | -20x | +374 | +9x |
- ~valname, ~label, ~levelcombo, ~exargs,+ split_fun = keep_split_levels("analysis"),
|
| 54 | -20x | +375 | +9x |
- paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
+ nested = FALSE, |
| 55 | -+ | |||
| 376 | +9x |
- )+ child_labels = "hidden" |
||
| 56 | +377 |
) |
||
| 57 | -+ | |||
| 378 | +9x |
- }+ lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE) |
||
| 58 | -19x | +379 | +9x |
- if (pct) combodf$valname <- paste0(combodf$valname, "_pct")+ lyt_hr <- analyze_colvars( |
| 59 | -19x | +380 | +9x |
- add_combo_levels(combodf)+ lyt = lyt_hr, |
| 60 | -+ | |||
| 381 | +9x |
- }+ afun = afun_lst[names(colvars_hr$labels)], |
||
| 61 | -+ | |||
| 382 | +9x |
-
+ na_str = na_str, |
||
| 62 | -+ | |||
| 383 | +9x |
- #' Analysis function to calculate risk difference column values+ inclNAs = TRUE, |
||
| 63 | -+ | |||
| 384 | +9x |
- #'+ extra_args = extra_args |
||
| 64 | +385 |
- #' In the risk difference column, this function uses the statistics function associated with `afun` to+ ) |
||
| 65 | +386 |
- #' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified+ } |
||
| 66 | +387 |
- #' when configuring the risk difference column which is done using the [add_riskdiff()] split function in+ |
||
| 67 | -+ | |||
| 388 | +10x |
- #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This+ table_hr <- build_table(lyt_hr, df = df$hr) |
||
| 68 | +389 |
- #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations.+ |
||
| 69 | +390 |
- #'+ # Join tables, add forest plot attributes |
||
| 70 | -+ | |||
| 391 | +10x |
- #' @inheritParams argument_convention+ n_tot_ids <- grep("^n_tot", colvars_hr$vars)
|
||
| 71 | -+ | |||
| 392 | +10x |
- #' @param afun (named `list`)\cr a named list containing one name-value pair where the name corresponds to+ if (is.null(table_survtime)) {
|
||
| 72 | -+ | |||
| 393 | +1x |
- #' the name of the statistics function that should be used in calculations and the value is the corresponding+ result <- table_hr |
||
| 73 | -+ | |||
| 394 | +1x |
- #' analysis function.+ hr_id <- match("hr", colvars_hr$vars)
|
||
| 74 | -+ | |||
| 395 | +1x |
- #' @param s_args (named `list`)\cr additional arguments to be passed to the statistics function and analysis+ ci_id <- match("ci", colvars_hr$vars)
|
||
| 75 | +396 |
- #' function supplied in `afun`.+ } else {
|
||
| 76 | -+ | |||
| 397 | +9x |
- #'+ result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids]) |
||
| 77 | -+ | |||
| 398 | +9x |
- #' @return A list of formatted [rtables::CellValue()].+ hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
|
||
| 78 | -+ | |||
| 399 | +9x |
- #'+ ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("ci", colvars_hr$vars[-n_tot_ids])
+ |
+ ||
| 400 | +9x | +
+ n_tot_ids <- seq_along(n_tot_ids) |
||
| 79 | +401 |
- #' @seealso+ }+ |
+ ||
| 402 | +10x | +
+ structure(+ |
+ ||
| 403 | +10x | +
+ result,+ |
+ ||
| 404 | +10x | +
+ forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ |
+ ||
| 405 | +10x | +
+ col_x = hr_id,+ |
+ ||
| 406 | +10x | +
+ col_ci = ci_id,+ |
+ ||
| 407 | +10x | +
+ col_symbol_size = n_tot_ids[1] # for scaling the symbol sizes in forest plots |
||
| 80 | +408 |
- #' * [stat_propdiff_ci()] for details on risk difference calculation.+ ) |
||
| 81 | +409 |
- #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with+ } |
||
| 82 | +410 |
- #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column+ |
||
| 83 | +411 |
- #' to a table layout.+ #' Labels for column variables in survival duration by subgroup table |
||
| 84 | +412 |
#' |
||
| 85 | +413 |
- #' @keywords internal+ #' @description `r lifecycle::badge("stable")`
|
||
| 86 | +414 |
- afun_riskdiff <- function(df,+ #' |
||
| 87 | +415 |
- labelstr = "",+ #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels. |
||
| 88 | +416 |
- .var,+ #' |
||
| 89 | +417 |
- .N_col, # nolint+ #' @inheritParams tabulate_survival_subgroups |
||
| 90 | +418 |
- .N_row, # nolint+ #' @inheritParams argument_convention |
||
| 91 | +419 |
- .df_row,+ #' @param method (`string`)\cr p-value method for testing hazard ratio = 1. |
||
| 92 | +420 |
- .spl_context,+ #' |
||
| 93 | +421 |
- .all_col_counts,+ #' @return A `list` of variables and their labels to tabulate. |
||
| 94 | +422 |
- .stats,+ #' |
||
| 95 | +423 |
- .formats = NULL,+ #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`. |
||
| 96 | +424 |
- .labels = NULL,+ #' |
||
| 97 | +425 |
- .indent_mods = NULL,+ #' @export |
||
| 98 | +426 |
- na_str = default_na_str(),+ d_survival_subgroups_colvars <- function(vars, |
||
| 99 | +427 |
- afun,+ conf_level, |
||
| 100 | -- |
- s_args = list()) {
- |
- ||
| 101 | -146x | -
- 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."- |
- ||
| 105 | +428 |
- )+ method, |
||
| 106 | +429 |
- }- |
- ||
| 107 | -146x | -
- checkmate::assert_list(afun, len = 1, types = "function")+ time_unit = NULL) {
|
||
| 108 | -146x | +430 | +21x |
- checkmate::assert_named(afun)+ checkmate::assert_character(vars) |
| 109 | -146x | +431 | +21x |
- afun_args <- list(+ checkmate::assert_string(time_unit, null.ok = TRUE) |
| 110 | -146x | +432 | +21x |
- .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr,+ checkmate::assert_subset(c("hr", "ci"), vars)
|
| 111 | -146x | -
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str- |
- ||
| 112 | -+ | 433 | +21x |
- )+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
|
| 113 | -146x | -
- 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
- |
- ||
| 115 | -+ | 434 | +21x |
-
+ checkmate::assert_subset( |
| 116 | -146x | +435 | +21x |
- cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1)+ vars, |
| 117 | -146x | +436 | +21x |
- if (!grepl("^riskdiff", cur_split)) {
+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
|
| 118 | +437 |
- # Apply basic afun (no risk difference) in all other columns- |
- ||
| 119 | -108x | -
- do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args))+ ) |
||
| 120 | +438 |
- } else {
- |
- ||
| 121 | -38x | -
- arm_x <- strsplit(cur_split, "_")[[1]][2]- |
- ||
| 122 | -38x | -
- arm_y <- strsplit(cur_split, "_")[[1]][3]- |
- ||
| 123 | -38x | -
- if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
+
|
||
| 124 | -8x | +439 | +21x |
- arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
+ propcase_time_label <- if (!is.null(time_unit)) {
|
| 125 | -8x | +440 | +20x |
- arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
+ paste0("Median (", time_unit, ")")
|
| 126 | +441 |
- } else {
- |
- ||
| 127 | -30x | -
- arm_spl_x <- arm_x+ } else {
|
||
| 128 | -30x | +442 | +1x |
- arm_spl_y <- arm_y+ "Median" |
| 129 | +443 |
- }- |
- ||
| 130 | -38x | -
- N_col_x <- .all_col_counts[[arm_spl_x]] # nolint- |
- ||
| 131 | -38x | -
- N_col_y <- .all_col_counts[[arm_spl_y]] # nolint- |
- ||
| 132 | -38x | -
- cur_var <- tail(.spl_context$cur_col_split[[1]], 1)+ } |
||
| 133 | +444 | |||
| 134 | -- |
- # Apply statistics function to arm X and arm Y data- |
- ||
| 135 | -38x | -
- s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))])- |
- ||
| 136 | -38x | -
- s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args))- |
- ||
| 137 | -38x | -
- s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args))- |
- ||
| 138 | -- | - - | -||
| 139 | -+ | 445 | +21x |
- # Get statistic name and row names+ varlabels <- c( |
| 140 | -38x | +446 | +21x |
- stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
+ n = "n", |
| 141 | -38x | +447 | +21x |
- if ("flag_variables" %in% names(s_args)) {
+ n_events = "Events", |
| 142 | -2x | +448 | +21x |
- var_nms <- s_args$flag_variables+ median = propcase_time_label, |
| 143 | -36x | +449 | +21x |
- } else if (!is.null(names(s_x[[stat]]))) {
+ n_tot = "Total n", |
| 144 | -24x | -
- var_nms <- names(s_x[[stat]])- |
- ||
| 145 | -+ | 450 | +21x |
- } else {
+ n_tot_events = "Total Events", |
| 146 | -12x | +451 | +21x |
- var_nms <- ""+ hr = "Hazard Ratio", |
| 147 | -12x | +452 | +21x |
- s_x[[stat]] <- list(s_x[[stat]])+ ci = paste0(100 * conf_level, "% Wald CI"), |
| 148 | -12x | -
- s_y[[stat]] <- list(s_y[[stat]])- |
- ||
| 149 | -- |
- }- |
- ||
| 150 | -+ | 453 | +21x |
-
+ pval = method |
| 151 | +454 |
- # Calculate risk difference for each row, repeated if multiple statistics in table- |
- ||
| 152 | -38x | -
- pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct"- |
- ||
| 153 | -38x | -
- rd_ci <- rep(stat_propdiff_ci(- |
- ||
| 154 | -38x | -
- lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1),- |
- ||
| 155 | -38x | -
- N_col_x, N_col_y,- |
- ||
| 156 | -38x | -
- list_names = var_nms,- |
- ||
| 157 | -38x | -
- pct = pct- |
- ||
| 158 | -38x | -
- ), max(1, length(.stats)))+ ) |
||
| 159 | +455 | |||
| 160 | -38x | -
- in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods)- |
- ||
| 161 | -- |
- }- |
- ||
| 162 | -+ | 456 | +21x |
- }+ colvars <- vars |
| 163 | +457 | |||
| 164 | -- |
- #' Control function for risk difference column- |
- ||
| 165 | -- |
- #'- |
- ||
| 166 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 167 | -- |
- #'- |
- ||
| 168 | -- |
- #' Sets a list of parameters to use when generating a risk (proportion) difference column. Used as input to the- |
- ||
| 169 | -- |
- #' `riskdiff` parameter of [tabulate_rsp_subgroups()] and [tabulate_survival_subgroups()].- |
- ||
| 170 | -- |
- #'- |
- ||
| 171 | -- |
- #' @inheritParams add_riskdiff- |
- ||
| 172 | -- |
- #' @param format (`string` or `function`)\cr the format label (string) or formatting function to apply to the risk- |
- ||
| 173 | -- |
- #' difference statistic. See the `3d` string options in [formatters::list_valid_format_labels()] for possible format- |
- ||
| 174 | -- |
- #' strings. Defaults to `"xx.x (xx.x - xx.x)"`.- |
- ||
| 175 | -- |
- #'- |
- ||
| 176 | -- |
- #' @return A `list` of items with names corresponding to the arguments.- |
- ||
| 177 | -- |
- #'- |
- ||
| 178 | -- |
- #' @seealso [add_riskdiff()], [tabulate_rsp_subgroups()], and [tabulate_survival_subgroups()].- |
- ||
| 179 | -- |
- #'- |
- ||
| 180 | -- |
- #' @examples- |
- ||
| 181 | -- |
- #' control_riskdiff()- |
- ||
| 182 | -- |
- #' control_riskdiff(arm_x = "ARM A", arm_y = "ARM B")- |
- ||
| 183 | -- |
- #'- |
- ||
| 184 | -- |
- #' @export- |
- ||
| 185 | +458 |
- control_riskdiff <- function(arm_x = NULL,+ # The `lcl` variable is just a placeholder available in the analysis data, |
||
| 186 | +459 |
- arm_y = NULL,+ # it is not acutally used in the tabulation. |
||
| 187 | +460 |
- format = "xx.x (xx.x - xx.x)",+ # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details. |
||
| 188 | -+ | |||
| 461 | +21x |
- col_label = "Risk Difference (%) (95% CI)",+ colvars[colvars == "ci"] <- "lcl" |
||
| 189 | +462 |
- pct = TRUE) {
- |
- ||
| 190 | -2x | -
- checkmate::assert_character(arm_x, len = 1, null.ok = TRUE)- |
- ||
| 191 | -2x | -
- checkmate::assert_character(arm_y, min.len = 1, null.ok = TRUE)+ |
||
| 192 | -2x | +463 | +21x |
- checkmate::assert_character(format, len = 1)+ list( |
| 193 | -2x | +464 | +21x |
- checkmate::assert_character(col_label)+ vars = colvars, |
| 194 | -2x | +465 | +21x |
- checkmate::assert_flag(pct)+ labels = varlabels[vars] |
| 195 | +466 | - - | -||
| 196 | -2x | -
- list(arm_x = arm_x, arm_y = arm_y, format = format, col_label = col_label, pct = pct)+ ) |
||
| 197 | +467 |
}@@ -36096,14 +35591,14 @@ tern coverage - 95.65% |
| 1 |
- #' Control function for descriptive statistics+ #' Count patient events in columns |
||
| 5 |
- #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify+ #' The summarize function [summarize_patients_events_in_cols()] creates a layout element to summarize patient |
||
| 6 |
- #' details for [s_summary()]. This function family is mainly used by [analyze_vars()].+ #' event counts in columns. |
||
| 8 |
- #' @inheritParams argument_convention+ #' This function analyzes the elements (events) supplied via the `filters_list` parameter and returns a row |
||
| 9 |
- #' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate.+ #' with counts of number of patients for each event as well as the total numbers of patients and events. |
||
| 10 |
- #' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used.+ #' The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`). |
||
| 11 |
- #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`.+ #' |
||
| 12 |
- #' This differs from R's default. See more about `type` in [stats::quantile()].+ #' If there are multiple occurrences of the same event recorded for a patient, the event is only counted once. |
||
| 13 |
- #' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating+ #' |
||
| 14 |
- #' p-value.+ #' @inheritParams argument_convention |
||
| 15 |
- #'+ #' @param filters_list (named `list` of `character`)\cr list where each element in this list describes one |
||
| 16 |
- #' @return A list of components with the same names as the arguments.+ #' type of event describe by filters, in the same format as [s_count_patients_with_event()]. |
||
| 17 |
- #'+ #' If it has a label, then this will be used for the column title. |
||
| 18 |
- #' @export+ #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such |
||
| 19 |
- control_analyze_vars <- function(conf_level = 0.95,+ #' that corresponding table cells will stay blank. |
||
| 20 |
- quantiles = c(0.25, 0.75),+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will |
||
| 21 |
- quantile_type = 2,+ #' be used as label. |
||
| 22 |
- test_mean = 0) {
+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 23 | -1091x | +
- checkmate::assert_vector(quantiles, len = 2)+ #' |
|
| 24 | -1091x | +
- checkmate::assert_int(quantile_type, lower = 1, upper = 9)+ #' In addition to any statistics added using `filters_list`, statistic options are: |
|
| 25 | -1091x | +
- checkmate::assert_numeric(test_mean)+ #' ``r shQuote(get_stats("summarize_patients_events_in_cols"))``
|
|
| 26 | -1091x | +
- lapply(quantiles, assert_proportion_value)+ #' |
|
| 27 | -1090x | +
- assert_proportion_value(conf_level)+ #' @name count_patients_events_in_cols |
|
| 28 | -1089x | +
- list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean)+ #' @order 1 |
|
| 29 |
- }+ NULL |
||
| 31 |
- #' Analyze variables+ #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple |
||
| 32 |
- #'+ #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`. |
||
| 33 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 34 |
- #'+ #' @return |
||
| 35 |
- #' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3+ #' * `s_count_patients_and_multiple_events()` returns a list with the statistics: |
||
| 36 |
- #' generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics for+ #' - `unique`: number of unique patients in `df`. |
||
| 37 |
- #' numeric variables can be viewed by running `get_stats("analyze_vars_numeric")` and for non-numeric variables by
+ #' - `all`: number of rows in `df`. |
||
| 38 |
- #' running `get_stats("analyze_vars_counts")`. Use the `.stats` parameter to specify the statistics to include in your
+ #' - one element with the same name as in `filters_list`: number of rows in `df`, |
||
| 39 |
- #' output summary table.+ #' i.e. events, fulfilling the filter condition. |
||
| 41 |
- #' @details+ #' @keywords internal |
||
| 42 |
- #' **Automatic digit formatting:** The number of digits to display can be automatically determined from the analyzed+ s_count_patients_and_multiple_events <- function(df, # nolint |
||
| 43 |
- #' variable(s) (`vars`) for certain statistics by setting the statistic format to `"auto"` in `.formats`.+ id, |
||
| 44 |
- #' This utilizes the [format_auto()] formatting function. Note that only data for the current row & variable (for all+ filters_list, |
||
| 45 |
- #' columns) will be considered (`.df_row[[.var]]`, see [`rtables::additional_fun_params`]) and not the whole dataset.+ empty_stats = character(), |
||
| 46 |
- #'+ labelstr = "", |
||
| 47 |
- #' @inheritParams argument_convention+ custom_label = NULL) {
|
||
| 48 | -+ | 9x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ checkmate::assert_list(filters_list, names = "named") |
| 49 | -+ | 9x |
- #'+ checkmate::assert_data_frame(df) |
| 50 | -+ | 9x |
- #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric"))``
+ checkmate::assert_string(id) |
| 51 | -+ | 9x |
- #'+ checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
|
| 52 | -+ | 9x |
- #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts"))``
+ checkmate::assert_character(empty_stats) |
| 53 | -+ | 9x |
- #'+ checkmate::assert_string(labelstr) |
| 54 | -+ | 9x |
- #' @name analyze_variables+ checkmate::assert_string(custom_label, null.ok = TRUE) |
| 55 |
- #' @order 1+ |
||
| 56 |
- NULL+ # Below we want to count each row in `df` once, therefore introducing this helper index column. |
||
| 57 | -+ | 9x |
-
+ df$.row_index <- as.character(seq_len(nrow(df))) |
| 58 | -+ | 9x |
- #' @describeIn analyze_variables S3 generic function to produces a variable summary.+ y <- list() |
| 59 | -+ | 9x |
- #'+ row_label <- if (labelstr != "") {
|
| 60 | -+ | ! |
- #' @return+ labelstr |
| 61 | -+ | 9x |
- #' * `s_summary()` returns different statistics depending on the class of `x`.+ } else if (!is.null(custom_label)) {
|
| 62 | -+ | 2x |
- #'+ custom_label |
| 63 |
- #' @export+ } else {
|
||
| 64 | -+ | 7x |
- s_summary <- function(x,+ "counts" |
| 65 |
- na.rm = TRUE, # nolint+ } |
||
| 66 | -+ | 9x |
- denom,+ y$unique <- formatters::with_label( |
| 67 | -+ | 9x |
- .N_row, # nolint+ s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L], |
| 68 | -+ | 9x |
- .N_col, # nolint+ row_label |
| 69 |
- .var,+ ) |
||
| 70 | -+ | 9x |
- ...) {
+ y$all <- formatters::with_label( |
| 71 | -1605x | +9x |
- checkmate::assert_flag(na.rm)+ nrow(df), |
| 72 | -1605x | +9x |
- UseMethod("s_summary", x)
+ row_label |
| 73 |
- }+ ) |
||
| 74 | -+ | 9x |
-
+ events <- Map( |
| 75 | -+ | 9x |
- #' @describeIn analyze_variables Method for `numeric` class.+ function(filters) {
|
| 76 | -+ | 25x |
- #'+ formatters::with_label( |
| 77 | -+ | 25x |
- #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using+ s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count, |
| 78 | -+ | 25x |
- #' the helper function [control_analyze_vars()]. Some possible parameter options are:+ row_label |
| 79 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median.+ ) |
||
| 80 |
- #' * `quantiles` (`numeric(2)`)\cr vector of length two to specify the quantiles.+ }, |
||
| 81 | -+ | 9x |
- #' * `quantile_type` (`numeric(1)`)\cr between 1 and 9 selecting quantile algorithms to be used.+ filters = filters_list |
| 82 |
- #' See more about `type` in [stats::quantile()].+ ) |
||
| 83 | -+ | 9x |
- #' * `test_mean` (`numeric(1)`)\cr value to test against the mean under the null hypothesis when calculating p-value.+ y_complete <- c(y, events) |
| 84 | -+ | 9x |
- #'+ y <- if (length(empty_stats) > 0) {
|
| 85 | -+ | 3x |
- #' @return+ y_reduced <- y_complete |
| 86 | -+ | 3x |
- #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items:+ for (stat in intersect(names(y_complete), empty_stats)) {
|
| 87 | -+ | 4x |
- #' * `n`: The [length()] of `x`.+ y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]])) |
| 88 |
- #' * `sum`: The [sum()] of `x`.+ } |
||
| 89 | -+ | 3x |
- #' * `mean`: The [mean()] of `x`.+ y_reduced |
| 90 |
- #' * `sd`: The [stats::sd()] of `x`.+ } else {
|
||
| 91 | -+ | 6x |
- #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`).+ y_complete |
| 92 |
- #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`.+ } |
||
| 93 | -+ | 9x |
- #' * `mean_se`: The [mean()] of `x` and its standard error (see above).+ y |
| 94 |
- #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]).+ } |
||
| 95 |
- #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]).+ |
||
| 96 |
- #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]).+ #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function |
||
| 97 |
- #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]).+ #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 98 |
- #' * `median`: The [stats::median()] of `x`.+ #' |
||
| 99 |
- #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`,+ #' @param col_split (`flag`)\cr whether the columns should be split. |
||
| 100 |
- #' where `xc` = `x` - [stats::median()]).+ #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe. |
||
| 101 |
- #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]).+ #' |
||
| 102 |
- #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]).+ #' @return |
||
| 103 |
- #' * `iqr`: The [stats::IQR()] of `x`.+ #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions, |
||
| 104 |
- #' * `range`: The [range_noinf()] of `x`.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 105 |
- #' * `min`: The [max()] of `x`.+ #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout. |
||
| 106 |
- #' * `max`: The [min()] of `x`.+ #' |
||
| 107 |
- #' * `median_range`: The [median()] and [range_noinf()] of `x`.+ #' @examples |
||
| 108 |
- #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100).+ #' df <- data.frame( |
||
| 109 |
- #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`).+ #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
|
||
| 110 |
- #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`).+ #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
|
||
| 111 |
- #'+ #' AESER = rep("Y", 7),
|
||
| 112 |
- #' @note+ #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
|
||
| 113 |
- #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in+ #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
|
||
| 114 |
- #' `rtables` when the intersection of a column and a row delimits an empty data selection.+ #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
|
||
| 115 |
- #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter+ #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
|
||
| 116 |
- #' being standard behavior in R.+ #' ) |
||
| 118 |
- #' @method s_summary numeric+ #' # `summarize_patients_events_in_cols()` |
||
| 119 |
- #'+ #' basic_table() %>% |
||
| 120 |
- #' @examples+ #' summarize_patients_events_in_cols( |
||
| 121 |
- #' # `s_summary.numeric`+ #' filters_list = list( |
||
| 122 |
- #'+ #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"), |
||
| 123 |
- #' ## Basic usage: empty numeric returns NA-filled items.+ #' fatal = c(AESDTH = "Y"), |
||
| 124 |
- #' s_summary(numeric())+ #' fatal_related = c(AEREL = "Y", AESDTH = "Y") |
||
| 125 |
- #'+ #' ), |
||
| 126 |
- #' ## Management of NA values.+ #' custom_label = "%s Total number of patients and events" |
||
| 127 |
- #' x <- c(NA_real_, 1)+ #' ) %>% |
||
| 128 |
- #' s_summary(x, na.rm = TRUE)+ #' build_table(df) |
||
| 129 |
- #' s_summary(x, na.rm = FALSE)+ #' |
||
| 130 |
- #'+ #' @export |
||
| 131 |
- #' x <- c(NA_real_, 1, 2)+ #' @order 2 |
||
| 132 |
- #' s_summary(x, stats = NULL)+ summarize_patients_events_in_cols <- function(lyt, # nolint |
||
| 133 |
- #'+ id = "USUBJID", |
||
| 134 |
- #' ## Benefits in `rtables` contructions:+ filters_list = list(), |
||
| 135 |
- #' dta_test <- data.frame(+ empty_stats = character(), |
||
| 136 |
- #' Group = rep(LETTERS[1:3], each = 2),+ na_str = default_na_str(), |
||
| 137 |
- #' sub_group = rep(letters[1:2], each = 3),+ ..., |
||
| 138 |
- #' x = 1:6+ .stats = c( |
||
| 139 |
- #' )+ "unique", |
||
| 140 |
- #'+ "all", |
||
| 141 |
- #' ## The summary obtained in with `rtables`:+ names(filters_list) |
||
| 142 |
- #' basic_table() %>%+ ), |
||
| 143 |
- #' split_cols_by(var = "Group") %>%+ .labels = c( |
||
| 144 |
- #' split_rows_by(var = "sub_group") %>%+ unique = "Patients (All)", |
||
| 145 |
- #' analyze(vars = "x", afun = s_summary) %>%+ all = "Events (All)", |
||
| 146 |
- #' build_table(df = dta_test)+ labels_or_names(filters_list) |
||
| 147 |
- #'+ ), |
||
| 148 |
- #' ## By comparison with `lapply`:+ col_split = TRUE) {
|
||
| 149 | -+ | 2x |
- #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group)))+ extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...) |
| 150 |
- #' lapply(X, function(x) s_summary(x$x))+ |
||
| 151 | -+ | 2x |
- #'+ afun_list <- Map( |
| 152 | -+ | 2x |
- #' @export+ function(stat) {
|
| 153 | -+ | 7x |
- s_summary.numeric <- function(x,+ make_afun( |
| 154 | -+ | 7x |
- na.rm = TRUE, # nolint+ s_count_patients_and_multiple_events, |
| 155 | -+ | 7x |
- denom,+ .stats = stat, |
| 156 | -+ | 7x |
- .N_row, # nolint+ .formats = "xx." |
| 157 |
- .N_col, # nolint+ ) |
||
| 158 |
- .var,+ }, |
||
| 159 | -+ | 2x |
- control = control_analyze_vars(),+ stat = .stats |
| 160 |
- ...) {
+ ) |
||
| 161 | -1134x | +2x |
- checkmate::assert_numeric(x)+ if (col_split) {
|
| 162 | -+ | 2x |
-
+ lyt <- split_cols_by_multivar( |
| 163 | -1134x | +2x |
- if (na.rm) {
+ lyt = lyt, |
| 164 | -1132x | +2x |
- x <- x[!is.na(x)]+ vars = rep(id, length(.stats)), |
| 165 | -+ | 2x |
- }+ varlabels = .labels[.stats] |
| 166 |
-
+ ) |
||
| 167 | -1134x | +
- y <- list()+ } |
|
| 168 | -+ | 2x |
-
+ summarize_row_groups( |
| 169 | -1134x | +2x |
- y$n <- c("n" = length(x))
+ lyt = lyt, |
| 170 | -+ | 2x |
-
+ cfun = afun_list, |
| 171 | -1134x | +2x |
- y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
+ na_str = na_str, |
| 172 | -+ | 2x |
-
+ extra_args = extra_args |
| 173 | -1134x | +
- y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
+ ) |
|
| 174 | - - | -||
| 175 | -1134x | -
- y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
+ } |
| 176 | +1 | - - | -||
| 177 | -1134x | -
- y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
+ #' Horizontal waterfall plot |
||
| 178 | +2 | - - | -||
| 179 | -1134x | -
- y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE))+ #' |
||
| 180 | +3 | - - | -||
| 181 | -1134x | -
- y$mean_se <- c(y$mean, y$se)+ #' @description `r lifecycle::badge("stable")`
|
||
| 182 | +4 | - - | -||
| 183 | -1134x | -
- mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)- |
- ||
| 184 | -1134x | -
- y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
+ #' |
||
| 185 | +5 | - - | -||
| 186 | -1134x | -
- mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n)- |
- ||
| 187 | -1134x | -
- names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
- |
- ||
| 188 | -1134x | -
- y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE")+ #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup. |
||
| 189 | +6 | - - | -||
| 190 | -1134x | -
- mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE)- |
- ||
| 191 | -1134x | -
- names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
- |
- ||
| 192 | -1134x | -
- y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD")+ #' |
||
| 193 | +7 | - - | -||
| 194 | -1134x | -
- mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2)- |
- ||
| 195 | -1134x | -
- y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
+ #' @param height (`numeric`)\cr vector containing values to be plotted as the waterfall bars. |
||
| 196 | +8 | - - | -||
| 197 | -1134x | -
- y$median <- c("median" = stats::median(x, na.rm = FALSE))
+ #' @param id (`character`)\cr vector containing identifiers to use as the x-axis label for the waterfall bars. |
||
| 198 | +9 | - - | -||
| 199 | -1134x | -
- y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
+ #' @param col (`character`)\cr color(s). |
||
| 200 | +10 | - - | -||
| 201 | -1134x | -
- median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)- |
- ||
| 202 | -1134x | -
- y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
+ #' @param col_var (`factor`, `character`, or `NULL`)\cr categorical variable for bar coloring. `NULL` by default. |
||
| 203 | +11 | - - | -||
| 204 | -1134x | -
- q <- control$quantiles- |
- ||
| 205 | -1134x | -
- if (any(is.na(x))) {
- |
- ||
| 206 | -2x | -
- qnts <- rep(NA_real_, length(q))+ #' @param xlab (`string`)\cr x label. Default is `"ID"`. |
||
| 207 | +12 |
- } else {
- |
- ||
| 208 | -1132x | -
- qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE)+ #' @param ylab (`string`)\cr y label. Default is `"Value"`. |
||
| 209 | +13 |
- }- |
- ||
| 210 | -1134x | -
- names(qnts) <- paste("quantile", q, sep = "_")
- |
- ||
| 211 | -1134x | -
- y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile"))+ #' @param title (`string`)\cr text to be displayed as plot title. |
||
| 212 | +14 | - - | -||
| 213 | -1134x | -
- y$iqr <- c("iqr" = ifelse(
- |
- ||
| 214 | -1134x | -
- any(is.na(x)),- |
- ||
| 215 | -1134x | -
- NA_real_,- |
- ||
| 216 | -1134x | -
- stats::IQR(x, na.rm = FALSE, type = control$quantile_type)+ #' @param col_legend_title (`string`)\cr text to be displayed as legend title. |
||
| 217 | +15 |
- ))+ #' |
||
| 218 | +16 | - - | -||
| 219 | -1134x | -
- y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
- |
- ||
| 220 | -1134x | -
- y$min <- y$range[1]- |
- ||
| 221 | -1134x | -
- y$max <- y$range[2]+ #' @return A `ggplot` waterfall plot. |
||
| 222 | +17 | - - | -||
| 223 | -1134x | -
- y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)")+ #' |
||
| 224 | +18 | - - | -||
| 225 | -1134x | -
- y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
+ #' @examples |
||
| 226 | +19 |
-
+ #' library(dplyr) |
||
| 227 | +20 |
- # Convert negative values to NA for log calculation.- |
- ||
| 228 | -1134x | -
- x_no_negative_vals <- x- |
- ||
| 229 | -1134x | -
- x_no_negative_vals[x_no_negative_vals <= 0] <- NA+ #' |
||
| 230 | -1134x | +|||
| 21 | +
- y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
+ #' g_waterfall(height = c(3, 5, -1), id = letters[1:3]) |
|||
| 231 | -1134x | +|||
| 22 | +
- geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE)+ #' |
|||
| 232 | -1134x | +|||
| 23 | +
- y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
+ #' g_waterfall( |
|||
| 233 | +24 |
-
+ #' height = c(3, 5, -1), |
||
| 234 | -1134x | +|||
| 25 | +
- y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
+ #' id = letters[1:3], |
|||
| 235 | +26 |
-
+ #' col_var = letters[1:3] |
||
| 236 | -1134x | +|||
| 27 | +
- y+ #' ) |
|||
| 237 | +28 |
- }+ #' |
||
| 238 | +29 |
-
+ #' adsl_f <- tern_ex_adsl %>% |
||
| 239 | +30 |
- #' @describeIn analyze_variables Method for `factor` class.+ #' select(USUBJID, STUDYID, ARM, ARMCD, SEX) |
||
| 240 | +31 |
#' |
||
| 241 | +32 |
- #' @return+ #' adrs_f <- tern_ex_adrs %>% |
||
| 242 | +33 |
- #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items:+ #' filter(PARAMCD == "OVRINV") %>% |
||
| 243 | +34 |
- #' * `n`: The [length()] of `x`.+ #' mutate(pchg = rnorm(n(), 10, 50)) |
||
| 244 | +35 |
- #' * `count`: A list with the number of cases for each level of the factor `x`.+ #' |
||
| 245 | +36 |
- #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the+ #' adrs_f <- head(adrs_f, 30) |
||
| 246 | +37 |
- #' factor `x` relative to the denominator, or `NA` if the denominator is zero.+ #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ] |
||
| 247 | +38 |
- #'+ #' head(adrs_f) |
||
| 248 | +39 |
- #' @note+ #' |
||
| 249 | +40 |
- #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element+ #' g_waterfall( |
||
| 250 | +41 |
- #' per factor level. If there are no levels in `x`, the function fails.+ #' height = adrs_f$pchg, |
||
| 251 | +42 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ #' id = adrs_f$USUBJID, |
||
| 252 | +43 |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ #' col_var = adrs_f$AVALC |
||
| 253 | +44 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ #' ) |
||
| 254 | +45 |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ #' |
||
| 255 | +46 |
- #'+ #' g_waterfall( |
||
| 256 | +47 |
- #' @method s_summary factor+ #' height = adrs_f$pchg, |
||
| 257 | +48 |
- #'+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 258 | +49 |
- #' @examples+ #' col_var = adrs_f$SEX |
||
| 259 | +50 |
- #' # `s_summary.factor`+ #' ) |
||
| 260 | +51 |
#' |
||
| 261 | +52 |
- #' ## Basic usage:+ #' g_waterfall( |
||
| 262 | +53 |
- #' s_summary(factor(c("a", "a", "b", "c", "a")))
+ #' height = adrs_f$pchg, |
||
| 263 | +54 |
- #'+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 264 | +55 |
- #' # Empty factor returns zero-filled items.+ #' xlab = "ID", |
||
| 265 | +56 |
- #' s_summary(factor(levels = c("a", "b", "c")))
+ #' ylab = "Percentage Change", |
||
| 266 | +57 |
- #'+ #' title = "Waterfall plot" |
||
| 267 | +58 |
- #' ## Management of NA values.+ #' ) |
||
| 268 | +59 |
- #' x <- factor(c(NA, "Female"))+ #' |
||
| 269 | +60 |
- #' x <- explicit_na(x)+ #' @export |
||
| 270 | +61 |
- #' s_summary(x, na.rm = TRUE)+ g_waterfall <- function(height, |
||
| 271 | +62 |
- #' s_summary(x, na.rm = FALSE)+ id, |
||
| 272 | +63 |
- #'+ col_var = NULL, |
||
| 273 | +64 |
- #' ## Different denominators.+ col = getOption("ggplot2.discrete.colour"),
|
||
| 274 | +65 |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ xlab = NULL, |
||
| 275 | +66 |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ ylab = NULL, |
||
| 276 | +67 |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ col_legend_title = NULL, |
||
| 277 | +68 |
- #'+ title = NULL) {
|
||
| 278 | -+ | |||
| 69 | +2x |
- #' @export+ if (!is.null(col_var)) {
|
||
| 279 | -+ | |||
| 70 | +1x |
- s_summary.factor <- function(x,+ check_same_n(height = height, id = id, col_var = col_var) |
||
| 280 | +71 |
- na.rm = TRUE, # nolint+ } else {
|
||
| 281 | -+ | |||
| 72 | +1x |
- denom = c("n", "N_col", "N_row"),
+ check_same_n(height = height, id = id) |
||
| 282 | +73 |
- .N_row, # nolint+ } |
||
| 283 | +74 |
- .N_col, # nolint+ |
||
| 284 | -+ | |||
| 75 | +2x |
- ...) {
+ checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
|
||
| 285 | -302x | +76 | +2x |
- assert_valid_factor(x)+ checkmate::assert_character(col, null.ok = TRUE) |
| 286 | +77 | |||
| 287 | -299x | +78 | +2x |
- if (na.rm) {
+ xlabel <- deparse(substitute(id)) |
| 288 | -290x | +79 | +2x |
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ ylabel <- deparse(substitute(height)) |
| 289 | +80 |
- } else {
+
|
||
| 290 | -9x | +81 | +2x |
- x <- x %>% explicit_na(label = "NA")+ col_label <- if (!missing(col_var)) {
+ |
+
| 82 | +1x | +
+ deparse(substitute(col_var)) |
||
| 291 | +83 |
} |
||
| 292 | +84 | |||
| 293 | -299x | +85 | +2x |
- y <- list()+ xlab <- if (is.null(xlab)) xlabel else xlab |
| 294 | -+ | |||
| 86 | +2x |
-
+ ylab <- if (is.null(ylab)) ylabel else ylab |
||
| 295 | -299x | +87 | +2x |
- y$n <- length(x)+ col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title |
| 296 | +88 | |||
| 297 | -299x | -
- y$count <- as.list(table(x, useNA = "ifany"))- |
- ||
| 298 | -+ | 89 | +2x |
-
+ plot_data <- data.frame( |
| 299 | -299x | +90 | +2x |
- denom <- match.arg(denom) %>%+ height = height, |
| 300 | -299x | +91 | +2x |
- switch(+ id = as.character(id), |
| 301 | -299x | +92 | +2x |
- n = length(x),+ col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)), |
| 302 | -299x | +93 | +2x |
- N_row = .N_row,+ stringsAsFactors = FALSE |
| 303 | -299x | +|||
| 94 | +
- N_col = .N_col+ ) |
|||
| 304 | +95 |
- )+ + |
+ ||
| 96 | +2x | +
+ plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ] |
||
| 305 | +97 | |||
| 306 | -299x | +98 | +2x |
- y$count_fraction <- lapply(+ p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) + |
| 307 | -299x | +99 | +2x |
- y$count,+ ggplot2::geom_col() + |
| 308 | -299x | +100 | +2x |
- function(x) {
+ ggplot2::geom_text( |
| 309 | -2172x | +101 | +2x |
- c(x, ifelse(denom > 0, x / denom, 0))+ label = format(plot_data_ord$height, digits = 2), |
| 310 | -+ | |||
| 102 | +2x |
- }+ vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5) |
||
| 311 | +103 |
- )+ ) + |
||
| 312 | -299x | +104 | +2x |
- y$fraction <- lapply(+ ggplot2::xlab(xlab) + |
| 313 | -299x | +105 | +2x |
- y$count,+ ggplot2::ylab(ylab) + |
| 314 | -299x | -
- function(count) c("num" = count, "denom" = denom)
- |
- ||
| 315 | -+ | 106 | +2x |
- )+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5)) |
| 316 | +107 | |||
| 317 | -299x | +108 | +2x |
- y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))
+ if (!is.null(col_var)) {
|
| 318 | -+ | |||
| 109 | +1x |
-
+ p <- p + |
||
| 319 | -299x | +110 | +1x |
- y+ ggplot2::aes(fill = col_var) + |
| 320 | -+ | |||
| 111 | +1x |
- }+ ggplot2::labs(fill = col_legend_title) + |
||
| 321 | -+ | |||
| 112 | +1x |
-
+ ggplot2::theme( |
||
| 322 | -+ | |||
| 113 | +1x |
- #' @describeIn analyze_variables Method for `character` class. This makes an automatic+ legend.position = "bottom", |
||
| 323 | -+ | |||
| 114 | +1x |
- #' conversion to factor (with a warning) and then forwards to the method for factors.+ legend.background = ggplot2::element_blank(), |
||
| 324 | -+ | |||
| 115 | +1x |
- #'+ legend.title = ggplot2::element_text(face = "bold"), |
||
| 325 | -+ | |||
| 116 | +1x |
- #' @param verbose (`flag`)\cr defaults to `TRUE`, which prints out warnings and messages. It is mainly used+ legend.box.background = ggplot2::element_rect(colour = "black") |
||
| 326 | +117 |
- #' to print out information about factor casting.+ ) |
||
| 327 | +118 |
- #'+ } |
||
| 328 | +119 |
- #' @note+ |
||
| 329 | -+ | |||
| 120 | +2x |
- #' * Automatic conversion of character to factor does not guarantee that the table+ if (!is.null(col)) {
|
||
| 330 | -+ | |||
| 121 | +1x |
- #' can be generated correctly. In particular for sparse tables this very likely can fail.+ p <- p + |
||
| 331 | -+ | |||
| 122 | +1x |
- #' It is therefore better to always pre-process the dataset such that factors are manually+ ggplot2::scale_fill_manual(values = col) |
||
| 332 | +123 |
- #' created from character variables before passing the dataset to [rtables::build_table()].+ } |
||
| 333 | +124 |
- #'+ |
||
| 334 | -+ | |||
| 125 | +2x |
- #' @method s_summary character+ if (!is.null(title)) {
|
||
| 335 | -+ | |||
| 126 | +1x |
- #'+ p <- p + |
||
| 336 | -+ | |||
| 127 | +1x |
- #' @examples+ ggplot2::labs(title = title) + |
||
| 337 | -+ | |||
| 128 | +1x |
- #' # `s_summary.character`+ ggplot2::theme(plot.title = ggplot2::element_text(face = "bold")) |
||
| 338 | +129 |
- #'+ } |
||
| 339 | +130 |
- #' ## Basic usage:+ |
||
| 340 | -+ | |||
| 131 | +2x |
- #' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
+ p |
||
| 341 | +132 |
- #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
+ } |
| 342 | +1 |
- #'+ #' Class for `CombinationFunction` |
||
| 343 | +2 |
- #' @export+ #' |
||
| 344 | +3 |
- s_summary.character <- function(x,+ #' @description `r lifecycle::badge("stable")`
|
||
| 345 | +4 |
- na.rm = TRUE, # nolint+ #' |
||
| 346 | +5 |
- denom = c("n", "N_col", "N_row"),
+ #' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that |
||
| 347 | +6 |
- .N_row, # nolint+ #' can be combined and negated with the logical operators. |
||
| 348 | +7 |
- .N_col, # nolint+ #' |
||
| 349 | +8 |
- .var,+ #' @param e1 (`CombinationFunction`)\cr left hand side of logical operator. |
||
| 350 | +9 |
- verbose = TRUE,+ #' @param e2 (`CombinationFunction`)\cr right hand side of logical operator. |
||
| 351 | +10 |
- ...) {
- |
- ||
| 352 | -8x | -
- if (na.rm) {
- |
- ||
| 353 | -7x | -
- y <- as_factor_keep_attributes(x, verbose = verbose)+ #' @param x (`CombinationFunction`)\cr the function which should be negated. |
||
| 354 | +11 |
- } else {
- |
- ||
| 355 | -1x | -
- y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA")+ #' |
||
| 356 | +12 |
- }+ #' @return A logical value indicating whether the left hand side of the equation equals the right hand side. |
||
| 357 | +13 |
-
+ #' |
||
| 358 | -8x | +|||
| 14 | +
- s_summary(+ #' @examples |
|||
| 359 | -8x | +|||
| 15 | +
- x = y,+ #' higher <- function(a) {
|
|||
| 360 | -8x | +|||
| 16 | +
- na.rm = na.rm,+ #' force(a) |
|||
| 361 | -8x | +|||
| 17 | +
- denom = denom,+ #' CombinationFunction( |
|||
| 362 | -8x | +|||
| 18 | +
- .N_row = .N_row,+ #' function(x) {
|
|||
| 363 | -8x | +|||
| 19 | +
- .N_col = .N_col,+ #' x > a |
|||
| 364 | +20 |
- ...+ #' } |
||
| 365 | +21 |
- )+ #' ) |
||
| 366 | +22 |
- }+ #' } |
||
| 367 | +23 |
-
+ #' |
||
| 368 | +24 |
- #' @describeIn analyze_variables Method for `logical` class.+ #' lower <- function(b) {
|
||
| 369 | +25 |
- #'+ #' force(b) |
||
| 370 | +26 |
- #' @return+ #' CombinationFunction( |
||
| 371 | +27 |
- #' * If `x` is of class `logical`, returns a `list` with named `numeric` items:+ #' function(x) {
|
||
| 372 | +28 |
- #' * `n`: The [length()] of `x` (possibly after removing `NA`s).+ #' x < b |
||
| 373 | +29 |
- #' * `count`: Count of `TRUE` in `x`.+ #' } |
||
| 374 | +30 |
- #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the+ #' ) |
||
| 375 | +31 |
- #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here.+ #' } |
||
| 376 | +32 |
#' |
||
| 377 | +33 |
- #' @method s_summary logical+ #' c1 <- higher(5) |
||
| 378 | +34 |
- #'+ #' c2 <- lower(10) |
||
| 379 | +35 |
- #' @examples+ #' c3 <- higher(5) & lower(10) |
||
| 380 | +36 |
- #' # `s_summary.logical`+ #' c3(7) |
||
| 381 | +37 |
#' |
||
| 382 | +38 |
- #' ## Basic usage:+ #' @name combination_function |
||
| 383 | +39 |
- #' s_summary(c(TRUE, FALSE, TRUE, TRUE))+ #' @aliases CombinationFunction-class |
||
| 384 | +40 |
- #'+ #' @exportClass CombinationFunction |
||
| 385 | +41 |
- #' # Empty factor returns zero-filled items.+ #' @export CombinationFunction |
||
| 386 | +42 |
- #' s_summary(as.logical(c()))+ CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint
|
||
| 387 | +43 |
- #'+ |
||
| 388 | +44 |
- #' ## Management of NA values.+ #' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions. |
||
| 389 | +45 |
- #' x <- c(NA, TRUE, FALSE)+ #' The resulting object is of the same class, and evaluates the two argument functions. The result |
||
| 390 | +46 |
- #' s_summary(x, na.rm = TRUE)+ #' is then the "AND" of the two individual results. |
||
| 391 | +47 |
- #' s_summary(x, na.rm = FALSE)+ #' |
||
| 392 | +48 |
- #'+ #' @export |
||
| 393 | +49 |
- #' ## Different denominators.+ methods::setMethod( |
||
| 394 | +50 |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ "&", |
||
| 395 | +51 |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"), |
||
| 396 | +52 |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ definition = function(e1, e2) {
|
||
| 397 | -+ | |||
| 53 | +4x |
- #'+ CombinationFunction(function(...) {
|
||
| 398 | -+ | |||
| 54 | +490x |
- #' @export+ e1(...) && e2(...) |
||
| 399 | +55 |
- s_summary.logical <- function(x,+ }) |
||
| 400 | +56 |
- na.rm = TRUE, # nolint+ } |
||
| 401 | +57 |
- denom = c("n", "N_col", "N_row"),
+ ) |
||
| 402 | +58 |
- .N_row, # nolint+ |
||
| 403 | +59 |
- .N_col, # nolint+ #' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions. |
||
| 404 | +60 |
- ...) {
+ #' The resulting object is of the same class, and evaluates the two argument functions. The result |
||
| 405 | -192x | +|||
| 61 | +
- if (na.rm) x <- x[!is.na(x)]+ #' is then the "OR" of the two individual results. |
|||
| 406 | -194x | +|||
| 62 | +
- y <- list()+ #' |
|||
| 407 | -194x | +|||
| 63 | +
- y$n <- length(x)+ #' @export |
|||
| 408 | -194x | +|||
| 64 | +
- count <- sum(x, na.rm = TRUE)+ methods::setMethod( |
|||
| 409 | -194x | +|||
| 65 | +
- denom <- match.arg(denom) %>%+ "|", |
|||
| 410 | -194x | +|||
| 66 | +
- switch(+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"), |
|||
| 411 | -194x | +|||
| 67 | +
- n = length(x),+ definition = function(e1, e2) {
|
|||
| 412 | -194x | +68 | +2x |
- N_row = .N_row,+ CombinationFunction(function(...) {
|
| 413 | -194x | +69 | +4x |
- N_col = .N_col+ e1(...) || e2(...) |
| 414 | +70 |
- )+ }) |
||
| 415 | -194x | +|||
| 71 | +
- y$count <- count+ } |
|||
| 416 | -194x | +|||
| 72 | +
- y$count_fraction <- c(count, ifelse(denom > 0, count / denom, 0))+ ) |
|||
| 417 | -194x | +|||
| 73 | +
- y$n_blq <- 0L+ |
|||
| 418 | -194x | +|||
| 74 | +
- y+ #' @describeIn combination_function Logical negation of `CombinationFunction` functions. |
|||
| 419 | +75 |
- }+ #' The resulting object is of the same class, and evaluates the original function. The result |
||
| 420 | +76 |
-
+ #' is then the opposite of this results. |
||
| 421 | +77 |
- #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and+ #' |
||
| 422 | +78 |
- #' `compare_vars()` and as `cfun` in `summarize_colvars()`.+ #' @export |
||
| 423 | +79 |
- #'+ methods::setMethod( |
||
| 424 | +80 |
- #' @param compare (`flag`)\cr whether comparison statistics should be analyzed instead of summary statistics+ "!", |
||
| 425 | +81 |
- #' (`compare = TRUE` adds `pval` statistic comparing against reference group).+ signature = c(x = "CombinationFunction"), |
||
| 426 | +82 |
- #'+ definition = function(x) {
|
||
| 427 | -+ | |||
| 83 | +2x |
- #' @return+ CombinationFunction(function(...) {
|
||
| 428 | -+ | |||
| 84 | +305x |
- #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()].+ !x(...) |
||
| 429 | +85 |
- #'+ }) |
||
| 430 | +86 |
- #' @note+ } |
||
| 431 | +87 |
- #' * To use for comparison (with additional p-value statistic), parameter `compare` must be set to `TRUE`.+ ) |
| 432 | +1 |
- #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is.+ #' Stack multiple grobs |
||
| 433 | +2 |
#' |
||
| 434 | +3 |
- #' @examples+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 435 | +4 |
- #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
+ #' |
||
| 436 | +5 |
- #' a_summary(+ #' Stack grobs as a new grob with 1 column and multiple rows layout. |
||
| 437 | +6 |
- #' factor(c("a", "a", "b", "c", "a")),
+ #' |
||
| 438 | +7 |
- #' .ref_group = factor(c("a", "a", "b", "c")), compare = TRUE
+ #' @param ... grobs. |
||
| 439 | +8 |
- #' )+ #' @param grobs (`list` of `grob`)\cr a list of grobs. |
||
| 440 | +9 |
- #'+ #' @param padding (`grid::unit`)\cr unit of length 1, space between each grob. |
||
| 441 | +10 |
- #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
+ #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
||
| 442 | +11 |
- #' a_summary(+ #' @param name (`string`)\cr a character identifier for the grob. |
||
| 443 | +12 |
- #' c("A", "B", "A", "C"),
+ #' @param gp (`gpar`)\cr a [gpar()] object. |
||
| 444 | +13 |
- #' .ref_group = c("B", "A", "C"), .var = "x", compare = TRUE, verbose = FALSE
+ #' |
||
| 445 | +14 |
- #' )+ #' @return A `grob`. |
||
| 446 | +15 |
#' |
||
| 447 | +16 |
- #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10)+ #' @examples |
||
| 448 | +17 |
- #' a_summary(+ #' library(grid) |
||
| 449 | +18 |
- #' c(TRUE, FALSE, FALSE, TRUE, TRUE),+ #' |
||
| 450 | +19 |
- #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare = TRUE+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
||
| 451 | +20 |
- #' )+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
||
| 452 | +21 |
- #'+ #' g3 <- textGrob("TEST TEXT")
|
||
| 453 | +22 |
- #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla")+ #' grid.newpage() |
||
| 454 | +23 |
- #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE)+ #' grid.draw(stack_grobs(g1, g2, g3)) |
||
| 455 | +24 |
#' |
||
| 456 | +25 |
- #' @export+ #' showViewport() |
||
| 457 | +26 |
- a_summary <- function(x,+ #' |
||
| 458 | +27 |
- .N_col, # nolint+ #' grid.newpage() |
||
| 459 | +28 |
- .N_row, # nolint+ #' pushViewport(viewport(layout = grid.layout(1, 2))) |
||
| 460 | +29 |
- .var = NULL,+ #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2) |
||
| 461 | +30 |
- .df_row = NULL,+ #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test")) |
||
| 462 | +31 |
- .ref_group = NULL,+ #' |
||
| 463 | +32 |
- .in_ref_col = FALSE,+ #' showViewport() |
||
| 464 | +33 |
- compare = FALSE,+ #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE) |
||
| 465 | +34 |
- .stats = NULL,+ #' |
||
| 466 | +35 |
- .formats = NULL,+ #' @export |
||
| 467 | +36 |
- .labels = NULL,+ stack_grobs <- function(..., |
||
| 468 | +37 |
- .indent_mods = NULL,+ grobs = list(...), |
||
| 469 | +38 |
- na.rm = TRUE, # nolint+ padding = grid::unit(2, "line"), |
||
| 470 | +39 |
- na_str = default_na_str(),+ vp = NULL, |
||
| 471 | +40 |
- ...) {
+ gp = NULL, |
||
| 472 | -324x | +|||
| 41 | +
- extra_args <- list(...)+ name = NULL) {
|
|||
| 473 | -324x | +42 | +4x |
- if (is.numeric(x)) {
+ lifecycle::deprecate_warn( |
| 474 | -86x | +43 | +4x |
- type <- "numeric"+ "0.9.4", |
| 475 | -86x | +44 | +4x |
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ "stack_grobs()", |
| 476 | -10x | +45 | +4x |
- .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
+ details = "`tern` plotting functions no longer generate `grob` objects." |
| 477 | +46 |
- }+ ) |
||
| 478 | +47 |
- } else {
- |
- ||
| 479 | -238x | -
- type <- "counts"+ |
||
| 480 | -238x | +48 | +4x |
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ checkmate::assert_true( |
| 481 | -9x | +49 | +4x |
- .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
+ all(vapply(grobs, grid::is.grob, logical(1))) |
| 482 | +50 |
- }+ ) |
||
| 483 | +51 |
- }+ |
||
| 484 | -+ | |||
| 52 | +4x |
-
+ if (length(grobs) == 1) {
|
||
| 485 | -+ | |||
| 53 | +1x |
- # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`)+ return(grobs[[1]]) |
||
| 486 | -! | +|||
| 54 | +
- if (any(is.na(.df_row[[.var]])) && !any(is.na(x)) && !na.rm) levels(x) <- c(levels(x), "fill-na-level")+ } |
|||
| 487 | +55 | |||
| 488 | -324x | +56 | +3x |
- x_stats <- if (!compare) {
+ n_layout <- 2 * length(grobs) - 1 |
| 489 | -300x | +57 | +3x |
- s_summary(x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, ...)+ hts <- lapply( |
| 490 | -+ | |||
| 58 | +3x |
- } else {
+ seq(1, n_layout), |
||
| 491 | -24x | +59 | +3x |
- s_compare(+ function(i) {
|
| 492 | -24x | +60 | +39x |
- x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, .ref_group = .ref_group, .in_ref_col = .in_ref_col, ...+ if (i %% 2 != 0) {
+ |
+
| 61 | +21x | +
+ grid::unit(1, "null") |
||
| 493 | +62 |
- )+ } else {
+ |
+ ||
| 63 | +18x | +
+ padding |
||
| 494 | +64 |
- }+ } |
||
| 495 | +65 |
-
+ } |
||
| 496 | +66 |
- # Fill in with formatting defaults if needed+ ) |
||
| 497 | -324x | +67 | +3x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ hts <- do.call(grid::unit.c, hts) |
| 498 | -324x | +|||
| 68 | +
- .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare)+ |
|||
| 499 | -324x | +69 | +3x |
- .formats <- get_formats_from_stats(.stats, .formats)+ main_vp <- grid::viewport( |
| 500 | -324x | +70 | +3x |
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts) |
| 501 | +71 | ++ |
+ )+ |
+ |
| 72 | ||||
| 502 | -324x | +73 | +3x |
- lbls <- get_labels_from_stats(.stats, .labels)+ nested_grobs <- Map(function(g, i) {
|
| 503 | -+ | |||
| 74 | +21x |
- # Check for custom labels from control_analyze_vars+ grid::gTree( |
||
| 504 | -324x | +75 | +21x |
- .labels <- if ("control" %in% names(extra_args)) {
+ children = grid::gList(g), |
| 505 | -1x | +76 | +21x |
- lbls %>% labels_use_control(extra_args[["control"]], .labels)+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1) |
| 506 | +77 |
- } else {
+ ) |
||
| 507 | -323x | +78 | +3x |
- lbls+ }, grobs, seq_along(grobs) * 2 - 1) |
| 508 | +79 |
- }+ |
||
| 509 | -+ | |||
| 80 | +3x |
-
+ grobs_mainvp <- grid::gTree( |
||
| 510 | -11x | +81 | +3x |
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ children = do.call(grid::gList, nested_grobs), |
| 511 | -324x | +82 | +3x |
- x_stats <- x_stats[.stats]+ vp = main_vp |
| 512 | +83 | - - | -||
| 513 | -324x | -
- if (is.factor(x) || is.character(x)) {
+ ) |
||
| 514 | +84 |
- # Ungroup statistics with values for each level of x+ |
||
| 515 | -234x | +85 | +3x |
- x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods)+ grid::gTree( |
| 516 | -234x | +86 | +3x |
- x_stats <- x_ungrp[["x"]]+ children = grid::gList(grobs_mainvp), |
| 517 | -234x | +87 | +3x |
- .formats <- x_ungrp[[".formats"]]+ vp = vp, |
| 518 | -234x | +88 | +3x |
- .labels <- gsub("fill-na-level", "NA", x_ungrp[[".labels"]])
+ gp = gp, |
| 519 | -234x | +89 | +3x |
- .indent_mods <- x_ungrp[[".indent_mods"]]+ name = name |
| 520 | +90 |
- }+ ) |
||
| 521 | +91 |
-
+ } |
||
| 522 | +92 |
- # Auto format handling+ |
||
| 523 | -324x | +|||
| 93 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' Arrange multiple grobs |
|||
| 524 | +94 |
-
+ #' |
||
| 525 | -324x | +|||
| 95 | +
- in_rows(+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 526 | -324x | +|||
| 96 | +
- .list = x_stats,+ #' |
|||
| 527 | -324x | +|||
| 97 | +
- .formats = .formats,+ #' Arrange grobs as a new grob with `n * m (rows * cols)` layout. |
|||
| 528 | -324x | +|||
| 98 | +
- .names = names(.labels),+ #' |
|||
| 529 | -324x | +|||
| 99 | +
- .labels = .labels,+ #' @inheritParams stack_grobs |
|||
| 530 | -324x | +|||
| 100 | +
- .indent_mods = .indent_mods,- |
- |||
| 531 | -324x | -
- .format_na_strs = na_str+ #' @param ncol (`integer(1)`)\cr number of columns in layout. |
||
| 532 | +101 |
- )+ #' @param nrow (`integer(1)`)\cr number of rows in layout. |
||
| 533 | +102 |
- }+ #' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob. |
||
| 534 | +103 |
-
+ #' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob. |
||
| 535 | +104 |
- #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments+ #' |
||
| 536 | +105 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @return A `grob`. |
||
| 537 | +106 |
#' |
||
| 538 | +107 |
- #' @param ... arguments passed to `s_summary()`.+ #' @examples |
||
| 539 | +108 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' library(grid) |
||
| 540 | +109 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' |
||
| 541 | +110 |
- #' for that statistic's row label.+ #' \donttest{
|
||
| 542 | +111 |
- #'+ #' num <- lapply(1:9, textGrob) |
||
| 543 | +112 |
- #' @return+ #' grid::grid.newpage() |
||
| 544 | +113 |
- #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions,+ #' grid.draw(arrange_grobs(grobs = num, ncol = 2)) |
||
| 545 | +114 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 546 | +115 |
- #' the statistics from `s_summary()` to the table layout.+ #' showViewport() |
||
| 547 | +116 |
#' |
||
| 548 | +117 |
- #' @examples+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
||
| 549 | +118 |
- #' ## Fabricated dataset.+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
||
| 550 | +119 |
- #' dta_test <- data.frame(+ #' g3 <- textGrob("TEST TEXT")
|
||
| 551 | +120 |
- #' USUBJID = rep(1:6, each = 3),+ #' grid::grid.newpage() |
||
| 552 | +121 |
- #' PARAMCD = rep("lab", 6 * 3),
+ #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2)) |
||
| 553 | +122 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' |
||
| 554 | +123 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' showViewport() |
||
| 555 | +124 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' |
||
| 556 | +125 |
- #' )+ #' grid::grid.newpage() |
||
| 557 | +126 |
- #'+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3)) |
||
| 558 | +127 |
- #' # `analyze_vars()` in `rtables` pipelines+ #' |
||
| 559 | +128 |
- #' ## Default output within a `rtables` pipeline.+ #' grid::grid.newpage() |
||
| 560 | +129 |
- #' l <- basic_table() %>%+ #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2))) |
||
| 561 | +130 |
- #' split_cols_by(var = "ARM") %>%+ #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2) |
||
| 562 | +131 |
- #' split_rows_by(var = "AVISIT") %>%+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1)) |
||
| 563 | +132 |
- #' analyze_vars(vars = "AVAL")+ #' |
||
| 564 | +133 |
- #'+ #' showViewport() |
||
| 565 | +134 |
- #' build_table(l, df = dta_test)+ #' } |
||
| 566 | +135 |
- #'+ #' @export |
||
| 567 | +136 |
- #' ## Select and format statistics output.+ arrange_grobs <- function(..., |
||
| 568 | +137 |
- #' l <- basic_table() %>%+ grobs = list(...), |
||
| 569 | +138 |
- #' split_cols_by(var = "ARM") %>%+ ncol = NULL, nrow = NULL, |
||
| 570 | +139 |
- #' split_rows_by(var = "AVISIT") %>%+ padding_ht = grid::unit(2, "line"), |
||
| 571 | +140 |
- #' analyze_vars(+ padding_wt = grid::unit(2, "line"), |
||
| 572 | +141 |
- #' vars = "AVAL",+ vp = NULL, |
||
| 573 | +142 |
- #' .stats = c("n", "mean_sd", "quantiles"),
+ gp = NULL, |
||
| 574 | +143 |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ name = NULL) {
|
||
| 575 | -+ | |||
| 144 | +5x |
- #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
+ lifecycle::deprecate_warn( |
||
| 576 | -+ | |||
| 145 | +5x |
- #' )+ "0.9.4", |
||
| 577 | -+ | |||
| 146 | +5x |
- #'+ "arrange_grobs()", |
||
| 578 | -+ | |||
| 147 | +5x |
- #' build_table(l, df = dta_test)+ details = "`tern` plotting functions no longer generate `grob` objects." |
||
| 579 | +148 |
- #'+ ) |
||
| 580 | +149 |
- #' ## Use arguments interpreted by `s_summary`.+ |
||
| 581 | -+ | |||
| 150 | +5x |
- #' l <- basic_table() %>%+ checkmate::assert_true( |
||
| 582 | -+ | |||
| 151 | +5x |
- #' split_cols_by(var = "ARM") %>%+ all(vapply(grobs, grid::is.grob, logical(1))) |
||
| 583 | +152 |
- #' split_rows_by(var = "AVISIT") %>%+ ) |
||
| 584 | +153 |
- #' analyze_vars(vars = "AVAL", na.rm = FALSE)+ |
||
| 585 | -+ | |||
| 154 | +5x |
- #'+ if (length(grobs) == 1) {
|
||
| 586 | -+ | |||
| 155 | +1x |
- #' build_table(l, df = dta_test)+ return(grobs[[1]]) |
||
| 587 | +156 |
- #'+ } |
||
| 588 | +157 |
- #' ## Handle `NA` levels first when summarizing factors.+ |
||
| 589 | -+ | |||
| 158 | +4x |
- #' dta_test$AVISIT <- NA_character_+ if (is.null(ncol) && is.null(nrow)) {
|
||
| 590 | -+ | |||
| 159 | +1x |
- #' dta_test <- df_explicit_na(dta_test)+ ncol <- 1 |
||
| 591 | -+ | |||
| 160 | +1x |
- #' l <- basic_table() %>%+ nrow <- ceiling(length(grobs) / ncol) |
||
| 592 | -+ | |||
| 161 | +3x |
- #' split_cols_by(var = "ARM") %>%+ } else if (!is.null(ncol) && is.null(nrow)) {
|
||
| 593 | -+ | |||
| 162 | +1x |
- #' analyze_vars(vars = "AVISIT", na.rm = FALSE)+ nrow <- ceiling(length(grobs) / ncol) |
||
| 594 | -+ | |||
| 163 | +2x |
- #'+ } else if (is.null(ncol) && !is.null(nrow)) {
|
||
| 595 | -+ | |||
| 164 | +! |
- #' build_table(l, df = dta_test)+ ncol <- ceiling(length(grobs) / nrow) |
||
| 596 | +165 |
- #'+ } |
||
| 597 | +166 |
- #' # auto format+ |
||
| 598 | -+ | |||
| 167 | +4x |
- #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
+ if (ncol * nrow < length(grobs)) {
|
||
| 599 | -+ | |||
| 168 | +1x |
- #' basic_table() %>%+ stop("specififed ncol and nrow are not enough for arranging the grobs ")
|
||
| 600 | +169 |
- #' analyze_vars(+ } |
||
| 601 | +170 |
- #' vars = "VAR",+ |
||
| 602 | -+ | |||
| 171 | +3x |
- #' .stats = c("n", "mean", "mean_sd", "range"),
+ if (ncol == 1) {
|
||
| 603 | -+ | |||
| 172 | +2x |
- #' .formats = c("mean_sd" = "auto", "range" = "auto")
+ return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name)) |
||
| 604 | +173 |
- #' ) %>%+ } |
||
| 605 | +174 |
- #' build_table(dt)+ |
||
| 606 | -+ | |||
| 175 | +1x |
- #'+ n_col <- 2 * ncol - 1 |
||
| 607 | -+ | |||
| 176 | +1x |
- #' @export+ n_row <- 2 * nrow - 1 |
||
| 608 | -+ | |||
| 177 | +1x |
- #' @order 2+ hts <- lapply( |
||
| 609 | -+ | |||
| 178 | +1x |
- analyze_vars <- function(lyt,+ seq(1, n_row), |
||
| 610 | -+ | |||
| 179 | +1x |
- vars,+ function(i) {
|
||
| 611 | -+ | |||
| 180 | +5x |
- var_labels = vars,+ if (i %% 2 != 0) {
|
||
| 612 | -+ | |||
| 181 | +3x |
- na_str = default_na_str(),+ grid::unit(1, "null") |
||
| 613 | +182 |
- nested = TRUE,+ } else {
|
||
| 614 | -+ | |||
| 183 | +2x |
- ...,+ padding_ht |
||
| 615 | +184 |
- na.rm = TRUE, # nolint+ } |
||
| 616 | +185 |
- show_labels = "default",+ } |
||
| 617 | +186 |
- table_names = vars,+ )+ |
+ ||
| 187 | +1x | +
+ hts <- do.call(grid::unit.c, hts) |
||
| 618 | +188 |
- section_div = NA_character_,+ + |
+ ||
| 189 | +1x | +
+ wts <- lapply(+ |
+ ||
| 190 | +1x | +
+ seq(1, n_col),+ |
+ ||
| 191 | +1x | +
+ function(i) {
+ |
+ ||
| 192 | +5x | +
+ if (i %% 2 != 0) {
+ |
+ ||
| 193 | +3x | +
+ grid::unit(1, "null") |
||
| 619 | +194 |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ } else {
+ |
+ ||
| 195 | +2x | +
+ padding_wt |
||
| 620 | +196 |
- .formats = NULL,+ } |
||
| 621 | +197 |
- .labels = NULL,+ } |
||
| 622 | +198 |
- .indent_mods = NULL) {
+ ) |
||
| 623 | -30x | +199 | +1x |
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...)+ wts <- do.call(grid::unit.c, wts) |
| 624 | -4x | +|||
| 200 | +
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ |
|||
| 625 | -2x | +201 | +1x |
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ main_vp <- grid::viewport( |
| 626 | -! | +|||
| 202 | +1x |
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts) |
||
| 627 | +203 |
-
+ ) |
||
| 628 | -30x | +|||
| 204 | +
- analyze(+ |
|||
| 629 | -30x | +205 | +1x |
- lyt = lyt,+ nested_grobs <- list() |
| 630 | -30x | +206 | +1x |
- vars = vars,+ k <- 0 |
| 631 | -30x | +207 | +1x |
- var_labels = var_labels,+ for (i in seq(nrow) * 2 - 1) {
|
| 632 | -30x | +208 | +3x |
- afun = a_summary,+ for (j in seq(ncol) * 2 - 1) {
|
| 633 | -30x | +209 | +9x |
- na_str = na_str,+ k <- k + 1 |
| 634 | -30x | +210 | +9x |
- nested = nested,+ if (k <= length(grobs)) {
|
| 635 | -30x | +211 | +9x |
- extra_args = extra_args,+ nested_grobs <- c( |
| 636 | -30x | +212 | +9x |
- inclNAs = TRUE,+ nested_grobs, |
| 637 | -30x | +213 | +9x |
- show_labels = show_labels,+ list(grid::gTree( |
| 638 | -30x | +214 | +9x |
- table_names = table_names,+ children = grid::gList(grobs[[k]]), |
| 639 | -30x | +215 | +9x |
- section_div = section_div+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = j) |
| 640 | +216 |
- )+ )) |
||
| 641 | +217 |
- }+ ) |
| 1 | +218 |
- # summarize_glm_count ----------------------------------------------------------+ } |
|
| 2 | +219 |
- #' Summarize Poisson negative binomial regression+ } |
|
| 3 | +220 |
- #'+ } |
|
| 4 | -+ | ||
| 221 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ grobs_mainvp <- grid::gTree( |
|
| 5 | -+ | ||
| 222 | +1x |
- #'+ children = do.call(grid::gList, nested_grobs), |
|
| 6 | -+ | ||
| 223 | +1x |
- #' Summarize results of a Poisson negative binomial regression.+ vp = main_vp |
|
| 7 | +224 |
- #' This can be used to analyze count and/or frequency data using a linear model.+ ) |
|
| 8 | +225 |
- #' It is specifically useful for analyzing count data (using the Poisson or Negative+ |
|
| 9 | -+ | ||
| 226 | +1x |
- #' Binomial distribution) that is result of a generalized linear model of one (e.g. arm) or more+ grid::gTree( |
|
| 10 | -+ | ||
| 227 | +1x |
- #' covariates.+ children = grid::gList(grobs_mainvp), |
|
| 11 | -+ | ||
| 228 | +1x |
- #'+ vp = vp,+ |
+ |
| 229 | +1x | +
+ gp = gp,+ |
+ |
| 230 | +1x | +
+ name = name |
|
| 12 | +231 |
- #' @inheritParams h_glm_count+ ) |
|
| 13 | +232 |
- #' @inheritParams argument_convention+ } |
|
| 14 | +233 |
- #' @param rate_mean_method (`character(1)`)\cr method used to estimate the mean odds ratio. Defaults to `emmeans`.+ |
|
| 15 | +234 |
- #' see details for more information.+ #' Draw `grob` |
|
| 16 | +235 |
- #' @param scale (`numeric(1)`)\cr linear scaling factor for rate and confidence intervals. Defaults to `1`.+ #' |
|
| 17 | +236 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @description `r lifecycle::badge("deprecated")`
|
|
| 18 | +237 |
#' |
|
| 19 | +238 |
- #' Options are: ``r shQuote(get_stats("summarize_glm_count"))``
+ #' Draw grob on device page. |
|
| 20 | +239 |
#' |
|
| 21 | +240 |
- #' @details+ #' @param grob (`grob`)\cr grid object. |
|
| 22 | +241 |
- #' `summarize_glm_count()` uses `s_glm_count()` to calculate the statistics for the table. This+ #' @param newpage (`flag`)\cr draw on a new page. |
|
| 23 | +242 |
- #' analysis function uses [h_glm_count()] to estimate the GLM with [stats::glm()] for Poisson and Quasi-Poisson+ #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
|
| 24 | +243 |
- #' distributions or [MASS::glm.nb()] for Negative Binomial distribution. All methods assume a+ #' |
|
| 25 | +244 |
- #' logarithmic link function.+ #' @return A `grob`. |
|
| 26 | +245 |
#' |
|
| 27 | +246 |
- #' At this point, rates and confidence intervals are estimated from the model using+ #' @examples |
|
| 28 | +247 |
- #' either [emmeans::emmeans()] when `rate_mean_method = "emmeans"` or [h_ppmeans()]+ #' library(dplyr) |
|
| 29 | +248 |
- #' when `rate_mean_method = "ppmeans"`.+ #' library(grid) |
|
| 30 | +249 |
#' |
|
| 31 | +250 |
- #' If a reference group is specified while building the table with `split_cols_by(ref_group)`,+ #' \donttest{
|
|
| 32 | +251 |
- #' no rate ratio or `p-value` are calculated. Otherwise, we use [emmeans::contrast()] to+ #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc")) |
|
| 33 | +252 |
- #' calculate the rate ratio and `p-value` for the reference group. Values are always estimated+ #' rect %>% draw_grob(vp = grid::viewport(angle = 45)) |
|
| 34 | +253 |
- #' with `method = "trt.vs.ctrl"` and `ref` equal to the first `arm` value.+ #' |
|
| 35 | +254 |
- #'+ #' num <- lapply(1:10, textGrob) |
|
| 36 | +255 |
- #' @name summarize_glm_count+ #' num %>% |
|
| 37 | +256 |
- NULL+ #' arrange_grobs(grobs = .) %>% |
|
| 38 | +257 |
-
+ #' draw_grob() |
|
| 39 | +258 |
- #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments+ #' showViewport() |
|
| 40 | +259 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' } |
|
| 41 | +260 |
#' |
|
| 42 | +261 |
- #' @return+ #' @export |
|
| 43 | +262 |
- #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions,+ draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
|
|
| 44 | -+ | ||
| 263 | +3x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ lifecycle::deprecate_warn( |
|
| 45 | -+ | ||
| 264 | +3x |
- #' the statistics from `s_glm_count()` to the table layout.+ "0.9.4", |
|
| 46 | -+ | ||
| 265 | +3x |
- #'+ "draw_grob()", |
|
| 47 | -+ | ||
| 266 | +3x |
- #' @examples+ details = "`tern` plotting functions no longer generate `grob` objects." |
|
| 48 | +267 |
- #' library(dplyr)+ ) |
|
| 49 | +268 |
- #'+ |
|
| 50 | -+ | ||
| 269 | +3x |
- #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE")+ if (newpage) {
|
|
| 51 | -+ | ||
| 270 | +3x |
- #' anl$AVAL_f <- as.factor(anl$AVAL)+ grid::grid.newpage() |
|
| 52 | +271 |
- #'+ } |
|
| 53 | -+ | ||
| 272 | +3x |
- #' lyt <- basic_table() %>%+ if (!is.null(vp)) {
|
|
| 54 | -+ | ||
| 273 | +1x |
- #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
+ grid::pushViewport(vp) |
|
| 55 | +274 |
- #' add_colcounts() %>%+ } |
|
| 56 | -+ | ||
| 275 | +3x |
- #' analyze_vars(+ grid::grid.draw(grob) |
|
| 57 | +276 |
- #' "AVAL_f",+ } |
|
| 58 | +277 |
- #' var_labels = "Number of exacerbations per patient",+ |
|
| 59 | +278 |
- #' .stats = c("count_fraction"),
+ tern_grob <- function(x) {
|
|
| 60 | -+ | ||
| 279 | +! |
- #' .formats = c("count_fraction" = "xx (xx.xx%)"),
+ class(x) <- unique(c("ternGrob", class(x)))
|
|
| 61 | -+ | ||
| 280 | +! |
- #' .labels = c("Number of exacerbations per patient")
+ x |
|
| 62 | +281 |
- #' ) %>%+ } |
|
| 63 | +282 |
- #' summarize_glm_count(+ |
|
| 64 | +283 |
- #' vars = "AVAL",+ #' @keywords internal |
|
| 65 | +284 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL),+ print.ternGrob <- function(x, ...) {
|
|
| 66 | -+ | ||
| 285 | +! |
- #' conf_level = 0.95,+ grid::grid.newpage() |
|
| 67 | -+ | ||
| 286 | +! |
- #' distribution = "poisson",+ grid::grid.draw(x) |
|
| 68 | +287 |
- #' rate_mean_method = "emmeans",+ } |
| 69 | +1 |
- #' var_labels = "Adjusted (P) exacerbation rate (per year)",+ #' Combine factor levels |
||
| 70 | +2 |
- #' table_names = "adjP",+ #' |
||
| 71 | +3 |
- #' .stats = c("rate"),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 72 | +4 |
- #' .labels = c(rate = "Rate")+ #' |
||
| 73 | +5 |
- #' ) %>%+ #' Combine specified old factor Levels in a single new level. |
||
| 74 | +6 |
- #' summarize_glm_count(+ #' |
||
| 75 | +7 |
- #' vars = "AVAL",+ #' @param x (`factor`)\cr factor variable. |
||
| 76 | +8 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
+ #' @param levels (`character`)\cr level names to be combined. |
||
| 77 | +9 |
- #' conf_level = 0.95,+ #' @param new_level (`string`)\cr name of new level. |
||
| 78 | +10 |
- #' distribution = "quasipoisson",+ #' |
||
| 79 | +11 |
- #' rate_mean_method = "ppmeans",+ #' @return A `factor` with the new levels. |
||
| 80 | +12 |
- #' var_labels = "Adjusted (QP) exacerbation rate (per year)",+ #' |
||
| 81 | +13 |
- #' table_names = "adjQP",+ #' @examples |
||
| 82 | +14 |
- #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ #' x <- factor(letters[1:5], levels = letters[5:1]) |
||
| 83 | +15 |
- #' .labels = c(+ #' combine_levels(x, levels = c("a", "b"))
|
||
| 84 | +16 |
- #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio",+ #' |
||
| 85 | +17 |
- #' rate_ratio_ci = "Rate Ratio CI", pval = "p value"+ #' combine_levels(x, c("e", "b"))
|
||
| 86 | +18 |
- #' )+ #' |
||
| 87 | +19 |
- #' )+ #' @export |
||
| 88 | +20 |
- #'+ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
|
||
| 89 | -+ | |||
| 21 | +4x |
- #' build_table(lyt = lyt, df = anl)+ checkmate::assert_factor(x) |
||
| 90 | -+ | |||
| 22 | +4x |
- #'+ checkmate::assert_subset(levels, levels(x)) |
||
| 91 | +23 |
- #' @export+ |
||
| 92 | -+ | |||
| 24 | +4x |
- summarize_glm_count <- function(lyt,+ lvls <- levels(x) |
||
| 93 | +25 |
- vars,+ |
||
| 94 | -+ | |||
| 26 | +4x |
- variables,+ lvls[lvls %in% levels] <- new_level |
||
| 95 | +27 |
- distribution,+ |
||
| 96 | -+ | |||
| 28 | +4x |
- conf_level,+ levels(x) <- lvls |
||
| 97 | +29 |
- rate_mean_method = c("emmeans", "ppmeans")[1],
+
|
||
| 98 | -+ | |||
| 30 | +4x |
- weights = stats::weights,+ x |
||
| 99 | +31 |
- scale = 1,+ } |
||
| 100 | +32 |
- var_labels,+ |
||
| 101 | +33 |
- na_str = default_na_str(),+ #' Conversion of a vector to a factor |
||
| 102 | +34 |
- nested = TRUE,+ #' |
||
| 103 | +35 |
- ...,+ #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user |
||
| 104 | +36 |
- show_labels = "visible",+ #' can decide whether they prefer converting to factor manually (e.g. for full control of |
||
| 105 | +37 |
- table_names = vars,+ #' factor levels). |
||
| 106 | +38 |
- .stats = get_stats("summarize_glm_count"),
+ #' |
||
| 107 | +39 |
- .formats = NULL,+ #' @param x (`vector`)\cr object to convert. |
||
| 108 | +40 |
- .labels = NULL,+ #' @param x_name (`string`)\cr name of `x`. |
||
| 109 | +41 |
- .indent_mods = c(+ #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector. |
||
| 110 | +42 |
- "n" = 0L,+ #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages. |
||
| 111 | +43 |
- "rate" = 0L,+ #' |
||
| 112 | +44 |
- "rate_ci" = 1L,+ #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. |
||
| 113 | +45 |
- "rate_ratio" = 0L,+ #' |
||
| 114 | +46 |
- "rate_ratio_ci" = 1L,+ #' @keywords internal |
||
| 115 | +47 |
- "pval" = 1L+ as_factor_keep_attributes <- function(x, |
||
| 116 | +48 |
- )) {
+ x_name = deparse(substitute(x)), |
||
| 117 | -3x | +|||
| 49 | +
- checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans"))
+ na_level = "<Missing>", |
|||
| 118 | +50 |
-
+ verbose = TRUE) {
|
||
| 119 | -3x | +51 | +205x |
- extra_args <- list(+ checkmate::assert_atomic(x) |
| 120 | -3x | +52 | +205x |
- variables = variables, distribution = distribution, conf_level = conf_level,+ checkmate::assert_string(x_name) |
| 121 | -3x | +53 | +205x |
- rate_mean_method = rate_mean_method, weights = weights, scale = scale, ...+ checkmate::assert_string(na_level) |
| 122 | -+ | |||
| 54 | +205x |
- )+ checkmate::assert_flag(verbose) |
||
| 123 | -+ | |||
| 55 | +205x |
-
+ if (is.factor(x)) {
|
||
| 124 | -+ | |||
| 56 | +186x |
- # Selecting parameters following the statistics+ return(x) |
||
| 125 | -3x | +|||
| 57 | +
- .formats <- get_formats_from_stats(.stats, formats_in = .formats)+ } |
|||
| 126 | -3x | +58 | +19x |
- .labels <- get_labels_from_stats(.stats, labels_in = .labels)+ x_class <- class(x)[1] |
| 127 | -3x | +59 | +19x |
- .indent_mods <- get_indents_from_stats(.stats, indents_in = .indent_mods)+ if (verbose) {
|
| 128 | -+ | |||
| 60 | +15x |
-
+ warning(paste( |
||
| 129 | -3x | +61 | +15x |
- afun <- make_afun(+ "automatically converting", x_class, "variable", x_name, |
| 130 | -3x | +62 | +15x |
- s_glm_count,+ "to factor, better manually convert to factor to avoid failures" |
| 131 | -3x | +|||
| 63 | +
- .stats = .stats,+ )) |
|||
| 132 | -3x | +|||
| 64 | +
- .formats = .formats,+ } |
|||
| 133 | -3x | +65 | +19x |
- .labels = .labels,+ if (identical(length(x), 0L)) {
|
| 134 | -3x | +66 | +1x |
- .indent_mods = .indent_mods,+ warning(paste( |
| 135 | -3x | +67 | +1x |
- .null_ref_cells = FALSE+ x_name, "has length 0, this can lead to tabulation failures, better convert to factor" |
| 136 | +68 |
- )+ )) |
||
| 137 | +69 | - - | -||
| 138 | -3x | -
- analyze(- |
- ||
| 139 | -3x | -
- lyt,+ } |
||
| 140 | -3x | +70 | +19x |
- vars,+ if (is.character(x)) {
|
| 141 | -3x | +71 | +19x |
- var_labels = var_labels,+ x_no_na <- explicit_na(sas_na(x), label = na_level) |
| 142 | -3x | +72 | +19x |
- show_labels = show_labels,+ if (any(na_level %in% x_no_na)) {
|
| 143 | +73 | 3x |
- table_names = table_names,+ do.call( |
|
| 144 | +74 | 3x |
- afun = afun,+ structure, |
|
| 145 | +75 | 3x |
- na_str = na_str,+ c( |
|
| 146 | +76 | 3x |
- nested = nested,+ list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)), |
|
| 147 | +77 | 3x |
- extra_args = extra_args+ attributes(x) |
|
| 148 | +78 |
- )+ ) |
||
| 149 | +79 |
- }+ ) |
||
| 150 | +80 |
-
+ } else {
|
||
| 151 | -+ | |||
| 81 | +16x |
- #' @describeIn summarize_glm_count Statistics function that produces a named list of results+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
||
| 152 | +82 |
- #' of the investigated Poisson model.+ } |
||
| 153 | +83 |
- #'+ } else {
|
||
| 154 | -+ | |||
| 84 | +! |
- #' @return+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
||
| 155 | +85 |
- #' * `s_glm_count()` returns a named `list` of 5 statistics:+ } |
||
| 156 | +86 |
- #' * `n`: Count of complete sample size for the group.+ } |
||
| 157 | +87 |
- #' * `rate`: Estimated event rate per follow-up time.+ |
||
| 158 | +88 |
- #' * `rate_ci`: Confidence level for estimated rate per follow-up time.+ #' Labels for bins in percent |
||
| 159 | +89 |
- #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm.+ #' |
||
| 160 | +90 |
- #' * `rate_ratio_ci`: Confidence level for the rate ratio.+ #' This creates labels for quantile based bins in percent. This assumes the right-closed |
||
| 161 | +91 |
- #' * `pval`: p-value.+ #' intervals as produced by [cut_quantile_bins()]. |
||
| 162 | +92 |
#' |
||
| 163 | -- |
- #' @keywords internal- |
- ||
| 164 | +93 |
- s_glm_count <- function(df,+ #' @param probs (`numeric`)\cr the probabilities identifying the quantiles. |
||
| 165 | +94 |
- .var,+ #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where |
||
| 166 | +95 |
- .df_row,+ #' the boundaries 0 and 1 must not be included. |
||
| 167 | +96 |
- variables,+ #' @param digits (`integer(1)`)\cr number of decimal places to round the percent numbers. |
||
| 168 | +97 |
- .ref_group,+ #' |
||
| 169 | +98 |
- .in_ref_col,+ #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc. |
||
| 170 | +99 |
- distribution,+ #' |
||
| 171 | +100 |
- conf_level,+ #' @keywords internal |
||
| 172 | +101 |
- rate_mean_method,+ bins_percent_labels <- function(probs, |
||
| 173 | +102 |
- weights,+ digits = 0) {
|
||
| 174 | -+ | |||
| 103 | +3x |
- scale = 1) {
+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
||
| 175 | -14x | +104 | +3x |
- arm <- variables$arm+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 176 | -+ | |||
| 105 | +10x |
-
+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
||
| 177 | -14x | +106 | +10x |
- y <- df[[.var]]+ percent <- round(probs * 100, digits = digits) |
| 178 | -13x | +107 | +10x |
- smry_level <- as.character(unique(df[[arm]]))+ left <- paste0(utils::head(percent, -1), "%") |
| 179 | -+ | |||
| 108 | +10x |
-
+ right <- paste0(utils::tail(percent, -1), "%") |
||
| 180 | -+ | |||
| 109 | +10x |
- # ensure there is only 1 value+ without_left_bracket <- paste0(left, ",", right, "]") |
||
| 181 | -13x | +110 | +10x |
- checkmate::assert_scalar(smry_level)+ with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
|
| 182 | -+ | |||
| 111 | +10x |
-
+ if (length(without_left_bracket) > 1) {
|
||
| 183 | -13x | +112 | +7x |
- results <- h_glm_count(+ with_left_bracket <- c( |
| 184 | -13x | +113 | +7x |
- .var = .var,+ with_left_bracket, |
| 185 | -13x | +114 | +7x |
- .df_row = .df_row,+ paste0("(", utils::tail(without_left_bracket, -1))
|
| 186 | -13x | +|||
| 115 | +
- variables = variables,+ ) |
|||
| 187 | -13x | +|||
| 116 | +
- distribution = distribution,+ } |
|||
| 188 | -13x | +117 | +10x |
- weights+ with_left_bracket |
| 189 | +118 |
- )+ } |
||
| 190 | +119 | |||
| 191 | -13x | +|||
| 120 | +
- if (rate_mean_method == "emmeans") {
+ #' Cut numeric vector into empirical quantile bins |
|||
| 192 | -13x | +|||
| 121 | +
- emmeans_smry <- summary(results$emmeans_fit, level = conf_level)+ #' |
|||
| 193 | -! | +|||
| 122 | +
- } else if (rate_mean_method == "ppmeans") {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 194 | -! | +|||
| 123 | +
- emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level)+ #' |
|||
| 195 | +124 |
- }+ #' This cuts a numeric vector into sample quantile bins. |
||
| 196 | +125 |
-
+ #' |
||
| 197 | -13x | +|||
| 126 | +
- emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ]+ #' @inheritParams bins_percent_labels |
|||
| 198 | +127 |
-
+ #' @param x (`numeric`)\cr the continuous variable values which should be cut into |
||
| 199 | +128 |
- # This happens if there is a reference col. No Ratio is calculated?+ #' quantile bins. This may contain `NA` values, which are then |
||
| 200 | -13x | +|||
| 129 | +
- if (.in_ref_col) {
+ #' not used for the quantile calculations, but included in the return vector. |
|||
| 201 | -5x | +|||
| 130 | +
- list(+ #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n` |
|||
| 202 | -5x | +|||
| 131 | +
- n = length(y[!is.na(y)]),+ #' probabilities in `probs`, then this must be `n + 1` long. |
|||
| 203 | -5x | +|||
| 132 | +
- rate = formatters::with_label(+ #' @param type (`integer(1)`)\cr type of quantiles to use, see [stats::quantile()] for details. |
|||
| 204 | -5x | +|||
| 133 | +
- ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate * scale),+ #' @param ordered (`flag`)\cr should the result be an ordered factor. |
|||
| 205 | -5x | +|||
| 134 | +
- "Adjusted Rate"+ #' |
|||
| 206 | +135 |
- ),+ #' @return A `factor` variable with appropriately-labeled bins as levels. |
||
| 207 | -5x | +|||
| 136 | +
- rate_ci = formatters::with_label(+ #' |
|||
| 208 | -5x | +|||
| 137 | +
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ #' @note Intervals are closed on the right side. That is, the first bin is the interval |
|||
| 209 | -5x | +|||
| 138 | +
- f_conf_level(conf_level)+ #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc., |
|||
| 210 | +139 |
- ),+ #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile. |
||
| 211 | -5x | +|||
| 140 | +
- rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"),+ #' |
|||
| 212 | -5x | +|||
| 141 | +
- rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ #' @examples |
|||
| 213 | -5x | +|||
| 142 | +
- pval = formatters::with_label(character(), "p-value")+ #' # Default is to cut into quartile bins. |
|||
| 214 | +143 |
- )+ #' cut_quantile_bins(cars$speed) |
||
| 215 | +144 |
- } else {
+ #' |
||
| 216 | -8x | +|||
| 145 | +
- emmeans_contrasts <- emmeans::contrast(+ #' # Use custom quantiles. |
|||
| 217 | -8x | +|||
| 146 | +
- results$emmeans_fit,+ #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88)) |
|||
| 218 | -8x | +|||
| 147 | +
- method = "trt.vs.ctrl",+ #' |
|||
| 219 | -8x | +|||
| 148 | +
- ref = grep(+ #' # Use custom labels. |
|||
| 220 | -8x | +|||
| 149 | +
- as.character(unique(.ref_group[[arm]])),+ #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
|
|||
| 221 | -8x | +|||
| 150 | +
- as.data.frame(results$emmeans_fit)[[arm]]+ #' |
|||
| 222 | +151 |
- )+ #' # NAs are preserved in result factor. |
||
| 223 | +152 |
- )+ #' ozone_binned <- cut_quantile_bins(airquality$Ozone) |
||
| 224 | +153 |
-
+ #' which(is.na(ozone_binned)) |
||
| 225 | -8x | +|||
| 154 | +
- contrasts_smry <- summary(+ #' # So you might want to make these explicit. |
|||
| 226 | -8x | +|||
| 155 | +
- emmeans_contrasts,+ #' explicit_na(ozone_binned) |
|||
| 227 | -8x | +|||
| 156 | +
- infer = TRUE,+ #' |
|||
| 228 | -8x | +|||
| 157 | +
- adjust = "none"+ #' @export |
|||
| 229 | +158 |
- )+ cut_quantile_bins <- function(x, |
||
| 230 | +159 |
-
+ probs = c(0.25, 0.5, 0.75), |
||
| 231 | -8x | +|||
| 160 | +
- smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ]+ labels = NULL, |
|||
| 232 | +161 |
-
+ type = 7, |
||
| 233 | -8x | +|||
| 162 | +
- list(+ ordered = TRUE) {
|
|||
| 234 | +163 | 8x |
- n = length(y[!is.na(y)]),+ checkmate::assert_flag(ordered) |
|
| 235 | +164 | 8x |
- rate = formatters::with_label(+ checkmate::assert_numeric(x) |
|
| 236 | -8x | +165 | +7x |
- ifelse(distribution == "negbin",+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 237 | -8x | +166 | +7x |
- emmeans_smry_level$response * scale,+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 238 | +167 | 8x |
- emmeans_smry_level$rate * scale+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
|
| 239 | -+ | |||
| 168 | +7x |
- ),+ if (is.null(labels)) labels <- bins_percent_labels(probs) |
||
| 240 | +169 | 8x |
- "Adjusted Rate"+ checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE) |
|
| 241 | +170 |
- ),+ |
||
| 242 | +171 | 8x |
- rate_ci = formatters::with_label(+ if (all(is.na(x))) {
|
|
| 243 | -8x | +|||
| 172 | +
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ # Early return if there are only NAs in input. |
|||
| 244 | -8x | +173 | +1x |
- f_conf_level(conf_level)+ return(factor(x, ordered = ordered, levels = labels)) |
| 245 | +174 |
- ),+ } |
||
| 246 | -8x | +|||
| 175 | +
- rate_ratio = formatters::with_label(+ |
|||
| 247 | -8x | +176 | +7x |
- smry_contrasts_level$ratio,+ quantiles <- stats::quantile( |
| 248 | -8x | +177 | +7x |
- "Adjusted Rate Ratio"+ x, |
| 249 | -+ | |||
| 178 | +7x |
- ),+ probs = probs, |
||
| 250 | -8x | +179 | +7x |
- rate_ratio_ci = formatters::with_label(+ type = type, |
| 251 | -8x | +180 | +7x |
- c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL),+ na.rm = TRUE |
| 252 | -8x | +|||
| 181 | +
- f_conf_level(conf_level)+ ) |
|||
| 253 | +182 |
- ),+ |
||
| 254 | -8x | +183 | +7x |
- pval = formatters::with_label(+ checkmate::assert_numeric(quantiles, unique = TRUE) |
| 255 | -8x | +|||
| 184 | +
- smry_contrasts_level$p.value,+ |
|||
| 256 | -8x | +185 | +6x |
- "p-value"+ cut( |
| 257 | -+ | |||
| 186 | +6x |
- )+ x, |
||
| 258 | -+ | |||
| 187 | +6x |
- )+ breaks = quantiles, |
||
| 259 | -+ | |||
| 188 | +6x |
- }+ labels = labels, |
||
| 260 | -+ | |||
| 189 | +6x |
- }+ ordered_result = ordered, |
||
| 261 | -+ | |||
| 190 | +6x |
- # h_glm_count ------------------------------------------------------------------+ include.lowest = TRUE, |
||
| 262 | -+ | |||
| 191 | +6x |
- #' Helper functions for Poisson models+ right = TRUE |
||
| 263 | +192 |
- #'+ ) |
||
| 264 | +193 |
- #' @description `r lifecycle::badge("experimental")`
+ } |
||
| 265 | +194 |
- #'+ |
||
| 266 | +195 |
- #' Helper functions that returns the results of [stats::glm()] when Poisson or Quasi-Poisson+ #' Discard specified levels of a factor |
||
| 267 | +196 |
- #' distributions are needed (see `family` parameter), or [MASS::glm.nb()] for Negative Binomial+ #' |
||
| 268 | +197 |
- #' distributions. Link function for the GLM is `log`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 269 | +198 |
#' |
||
| 270 | +199 |
- #' @inheritParams argument_convention+ #' This discards the observations as well as the levels specified from a factor. |
||
| 271 | +200 |
#' |
||
| 272 | +201 |
- #' @seealso [summarize_glm_count]+ #' @param x (`factor`)\cr the original factor. |
||
| 273 | +202 |
- #'+ #' @param discard (`character`)\cr levels to discard. |
||
| 274 | +203 |
- #' @name h_glm_count+ #' |
||
| 275 | +204 |
- NULL+ #' @return A modified `factor` with observations as well as levels from `discard` dropped. |
||
| 276 | +205 |
-
+ #' |
||
| 277 | +206 |
- #' @describeIn h_glm_count Helper function to return the results of the+ #' @examples |
||
| 278 | +207 |
- #' selected model (Poisson, Quasi-Poisson, negative binomial).+ #' fct_discard(factor(c("a", "b", "c")), "c")
|
||
| 279 | +208 |
#' |
||
| 280 | +209 |
- #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called+ #' @export |
||
| 281 | +210 |
- #' in `.var` and `variables`.+ fct_discard <- function(x, discard) {
|
||
| 282 | -+ | |||
| 211 | +319x |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with+ checkmate::assert_factor(x) |
||
| 283 | -+ | |||
| 212 | +319x |
- #' expected elements:+ checkmate::assert_character(discard, any.missing = FALSE)+ |
+ ||
| 213 | +319x | +
+ new_obs <- x[!(x %in% discard)]+ |
+ ||
| 214 | +319x | +
+ new_levels <- setdiff(levels(x), discard)+ |
+ ||
| 215 | +319x | +
+ factor(new_obs, levels = new_levels) |
||
| 284 | +216 |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple+ } |
||
| 285 | +217 |
- #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the+ |
||
| 286 | +218 |
- #' reference group.+ #' Insertion of explicit missing values in a factor |
||
| 287 | +219 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as+ #' |
||
| 288 | +220 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 289 | +221 |
- #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.+ #' |
||
| 290 | +222 |
- #' @param distribution (`character`)\cr a character value specifying the distribution+ #' This inserts explicit missing values in a factor based on a condition. Additionally, |
||
| 291 | +223 |
- #' used in the regression (Poisson, Quasi-Poisson, negative binomial).+ #' existing `NA` values will be explicitly converted to given `na_level`. |
||
| 292 | +224 |
- #' @param weights (`character`)\cr a character vector specifying weights used+ #' |
||
| 293 | +225 |
- #' in averaging predictions. Number of weights must equal the number of levels included in the covariates.+ #' @param x (`factor`)\cr the original factor. |
||
| 294 | +226 |
- #' Weights option passed to [emmeans::emmeans()].+ #' @param condition (`logical`)\cr positions at which to insert missing values. |
||
| 295 | +227 |
- #'+ #' @param na_level (`string`)\cr which level to use for missing values. |
||
| 296 | +228 |
- #' @return+ #' |
||
| 297 | +229 |
- #' * `h_glm_count()` returns the results of the selected model.+ #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`. |
||
| 298 | +230 |
#' |
||
| 299 | +231 |
- #' @keywords internal+ #' @seealso [forcats::fct_na_value_to_level()] which is used internally. |
||
| 300 | +232 |
- h_glm_count <- function(.var,+ #' |
||
| 301 | +233 |
- .df_row,+ #' @examples |
||
| 302 | +234 |
- variables,+ #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
|
||
| 303 | +235 |
- distribution,+ #' |
||
| 304 | +236 |
- weights) {
+ #' @export |
||
| 305 | -21x | +|||
| 237 | +
- checkmate::assert_subset(distribution, c("poisson", "quasipoisson", "negbin"), empty.ok = FALSE)
+ fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
|
|||
| 306 | -19x | +238 | +1x |
- switch(distribution,+ checkmate::assert_factor(x, len = length(condition)) |
| 307 | -13x | +239 | +1x |
- poisson = h_glm_poisson(.var, .df_row, variables, weights),+ checkmate::assert_logical(condition) |
| 308 | +240 | 1x |
- quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights),+ x[condition] <- NA |
|
| 309 | -5x | +241 | +1x |
- negbin = h_glm_negbin(.var, .df_row, variables, weights)+ x <- forcats::fct_na_value_to_level(x, level = na_level) |
| 310 | -+ | |||
| 242 | +1x |
- )+ forcats::fct_drop(x, only = na_level) |
||
| 311 | +243 |
} |
||
| 312 | +244 | |||
| 313 | +245 |
- #' @describeIn h_glm_count Helper function to return results of a Poisson model.+ #' Collapse factor levels and keep only those new group levels |
||
| 314 | +246 |
#' |
||
| 315 | +247 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
||
| 316 | +248 |
- #' * `h_glm_poisson()` returns the results of a Poisson model.+ #' |
||
| 317 | +249 |
- #'+ #' This collapses levels and only keeps those new group levels, in the order provided. |
||
| 318 | +250 |
- #' @keywords internal+ #' The returned factor has levels in the order given, with the possible missing level last (this will |
||
| 319 | +251 |
- h_glm_poisson <- function(.var,+ #' only be included if there are missing values). |
||
| 320 | +252 |
- .df_row,+ #' |
||
| 321 | +253 |
- variables,+ #' @param .f (`factor` or `character`)\cr original vector. |
||
| 322 | +254 |
- weights) {
- |
- ||
| 323 | -17x | -
- arm <- variables$arm- |
- ||
| 324 | -17x | -
- covariates <- variables$covariates- |
- ||
| 325 | -17x | -
- offset <- .df_row[[variables$offset]]+ #' @param ... (named `character`)\cr levels in each vector provided will be collapsed into |
||
| 326 | +255 |
-
+ #' the new level given by the respective name. |
||
| 327 | -15x | +|||
| 256 | +
- formula <- stats::as.formula(paste0(+ #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the |
|||
| 328 | -15x | +|||
| 257 | +
- .var, " ~ ",+ #' new factor. Note that this level must not be contained in the new levels specified in `...`. |
|||
| 329 | +258 |
- " + ",+ #' |
||
| 330 | -15x | +|||
| 259 | +
- paste(covariates, collapse = " + "),+ #' @return A modified `factor` with collapsed levels. Values and levels which are not included |
|||
| 331 | +260 |
- " + ",+ #' in the given `character` vector input will be set to the missing level `.na_level`. |
||
| 332 | -15x | +|||
| 261 | +
- arm+ #' |
|||
| 333 | +262 |
- ))+ #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed, |
||
| 334 | +263 |
-
+ #' [explicit_na()] can be called separately on the result. |
||
| 335 | -15x | +|||
| 264 | +
- glm_fit <- stats::glm(+ #' |
|||
| 336 | -15x | +|||
| 265 | +
- formula = formula,+ #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally. |
|||
| 337 | -15x | +|||
| 266 | +
- offset = offset,+ #' |
|||
| 338 | -15x | +|||
| 267 | +
- data = .df_row,+ #' @examples |
|||
| 339 | -15x | +|||
| 268 | +
- family = stats::poisson(link = "log")+ #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
|
|||
| 340 | +269 |
- )+ #' |
||
| 341 | +270 |
-
+ #' @export |
||
| 342 | -15x | +|||
| 271 | +
- emmeans_fit <- emmeans::emmeans(+ fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
|
|||
| 343 | -15x | +272 | +4x |
- glm_fit,+ new_lvls <- names(list(...)) |
| 344 | -15x | +273 | +4x |
- specs = arm,+ if (checkmate::test_subset(.na_level, new_lvls)) {
|
| 345 | -15x | +274 | +1x |
- data = .df_row,+ stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
|
| 346 | -15x | +|||
| 275 | +
- type = "response",+ } |
|||
| 347 | -15x | +276 | +3x |
- offset = 0,+ x <- forcats::fct_collapse(.f, ..., other_level = .na_level) |
| 348 | -15x | +277 | +3x |
- weights = weights+ do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls))) |
| 349 | +278 |
- )+ } |
||
| 350 | +279 | |||
| 351 | -15x | +|||
| 280 | +
- list(+ #' Ungroup non-numeric statistics |
|||
| 352 | -15x | +|||
| 281 | +
- glm_fit = glm_fit,+ #' |
|||
| 353 | -15x | +|||
| 282 | +
- emmeans_fit = emmeans_fit+ #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`. |
|||
| 354 | +283 |
- )+ #' |
||
| 355 | +284 |
- }+ #' @inheritParams argument_convention |
||
| 356 | +285 |
-
+ #' @param x (named `list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup. |
||
| 357 | +286 |
- #' @describeIn h_glm_count Helper function to return results of a Quasi-Poisson model.+ #' |
||
| 358 | +287 |
- #'+ #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`. |
||
| 359 | +288 |
- #' @return+ #' |
||
| 360 | +289 |
- #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model.+ #' @seealso [a_summary()] which uses this function internally. |
||
| 361 | +290 |
#' |
||
| 362 | +291 |
#' @keywords internal |
||
| 363 | +292 |
- h_glm_quasipoisson <- function(.var,+ ungroup_stats <- function(x, |
||
| 364 | +293 |
- .df_row,+ .formats, |
||
| 365 | +294 |
- variables,+ .labels, |
||
| 366 | +295 |
- weights) {
+ .indent_mods) {
|
||
| 367 | -5x | +296 | +403x |
- arm <- variables$arm+ checkmate::assert_list(x) |
| 368 | -5x | +297 | +403x |
- covariates <- variables$covariates+ empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0 |
| 369 | -5x | +298 | +403x |
- offset <- .df_row[[variables$offset]]+ empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0+ |
+
| 299 | +403x | +
+ x <- unlist(x, recursive = FALSE) |
||
| 370 | +300 | |||
| 371 | -3x | +|||
| 301 | +
- formula <- stats::as.formula(paste0(+ # If p-value is empty it is removed by unlist and needs to be re-added+ |
+ |||
| 302 | +! | +
+ if (empty_pval) x[["pval"]] <- character() |
||
| 372 | +303 | 3x |
- .var, " ~ ",+ if (empty_pval_counts) x[["pval_counts"]] <- character() |
|
| 373 | -+ | |||
| 304 | +403x |
- " + ",+ .stats <- names(x) |
||
| 374 | -3x | +|||
| 305 | +
- paste(covariates, collapse = " + "),+ |
|||
| 375 | +306 |
- " + ",+ # Ungroup stats |
||
| 376 | -3x | +307 | +403x |
- arm+ .formats <- lapply(.stats, function(x) {
|
| 377 | -+ | |||
| 308 | +2985x |
- ))+ .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
|
||
| 378 | +309 |
-
+ }) |
||
| 379 | -3x | +310 | +403x |
- glm_fit <- stats::glm(+ .indent_mods <- sapply(.stats, function(x) {
|
| 380 | -3x | +311 | +2985x |
- formula = formula,+ .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
|
| 381 | -3x | +|||
| 312 | +
- offset = offset,+ }) |
|||
| 382 | -3x | +313 | +403x |
- data = .df_row,+ .labels <- sapply(.stats, function(x) {
|
| 383 | -3x | +314 | +2916x |
- family = stats::quasipoisson(link = "log")+ if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
|
| 384 | +315 |
- )+ }) |
||
| 385 | +316 | |||
| 386 | -3x | +317 | +403x |
- emmeans_fit <- emmeans::emmeans(+ list( |
| 387 | -3x | +318 | +403x |
- glm_fit,+ x = x, |
| 388 | -3x | +319 | +403x |
- specs = arm,+ .formats = .formats, |
| 389 | -3x | +320 | +403x |
- data = .df_row,+ .labels = .labels, |
| 390 | -3x | +321 | +403x |
- type = "response",+ .indent_mods = .indent_mods |
| 391 | -3x | +|||
| 322 | +
- offset = 0,+ ) |
|||
| 392 | -3x | +|||
| 323 | +
- weights = weights+ } |
| 393 | +1 |
- )+ #' Apply 1/3 or 1/2 imputation rule to data |
||
| 394 | +2 |
-
+ #' |
||
| 395 | -3x | +|||
| 3 | +
- list(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 396 | -3x | +|||
| 4 | +
- glm_fit = glm_fit,+ #' |
|||
| 397 | -3x | +|||
| 5 | +
- emmeans_fit = emmeans_fit+ #' @inheritParams argument_convention |
|||
| 398 | +6 |
- )+ #' @param x_stats (named `list`)\cr a named list of statistics, typically the results of [s_summary()]. |
||
| 399 | +7 |
- }+ #' @param stat (`string`)\cr statistic to return the value/NA level of according to the imputation |
||
| 400 | +8 |
-
+ #' rule applied. |
||
| 401 | +9 |
- #' @describeIn h_glm_count Helper function to return results of a negative binomial model.+ #' @param imp_rule (`string`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation |
||
| 402 | +10 |
- #'+ #' rule or `"1/2"` to implement 1/2 imputation rule. |
||
| 403 | +11 |
- #' @return+ #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`). |
||
| 404 | +12 |
- #' * `h_glm_negbin()` returns the results of a negative binomial model.+ #' This parameter is only used when `imp_rule` is set to `"1/3"`. |
||
| 405 | +13 |
- #'+ #' @param avalcat_var (`string`)\cr name of variable that indicates whether a row in `df` corresponds |
||
| 406 | +14 |
- #' @keywords internal+ #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above |
||
| 407 | +15 |
- h_glm_negbin <- function(.var,+ #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`. |
||
| 408 | +16 |
- .df_row,+ #' |
||
| 409 | +17 |
- variables,+ #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed |
||
| 410 | +18 |
- weights) {
+ #' according to the specified imputation rule. |
||
| 411 | -9x | +|||
| 19 | +
- arm <- variables$arm+ #' |
|||
| 412 | -9x | +|||
| 20 | +
- covariates <- variables$covariates+ #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule` |
|||
| 413 | +21 |
-
+ #' argument. |
||
| 414 | -9x | +|||
| 22 | +
- formula <- stats::as.formula(paste0(+ #' |
|||
| 415 | -9x | +|||
| 23 | +
- .var, " ~ ",+ #' @examples |
|||
| 416 | +24 |
- " + ",+ #' set.seed(1) |
||
| 417 | -9x | +|||
| 25 | +
- paste(covariates, collapse = " + "),+ #' df <- data.frame( |
|||
| 418 | +26 |
- " + ",+ #' AVAL = runif(50, 0, 1), |
||
| 419 | -9x | +|||
| 27 | +
- arm+ #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE) |
|||
| 420 | +28 |
- ))+ #' ) |
||
| 421 | +29 |
-
+ #' x_stats <- s_summary(df$AVAL) |
||
| 422 | -9x | +|||
| 30 | +
- glm_fit <- MASS::glm.nb(+ #' imputation_rule(df, x_stats, "max", "1/3") |
|||
| 423 | -9x | +|||
| 31 | +
- formula = formula,+ #' imputation_rule(df, x_stats, "geom_mean", "1/3") |
|||
| 424 | -9x | +|||
| 32 | +
- data = .df_row,+ #' imputation_rule(df, x_stats, "mean", "1/2") |
|||
| 425 | -9x | +|||
| 33 | +
- link = "log"+ #' |
|||
| 426 | +34 |
- )+ #' @export |
||
| 427 | +35 |
-
+ imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
|
||
| 428 | -7x | +36 | +128x |
- emmeans_fit <- emmeans::emmeans(+ checkmate::assert_choice(avalcat_var, names(df)) |
| 429 | -7x | +37 | +128x |
- glm_fit,+ checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
|
| 430 | -7x | +38 | +128x |
- specs = arm,+ n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
|
| 431 | -7x | +39 | +128x |
- data = .df_row,+ ltr_blq_ratio <- n_blq / max(1, nrow(df)) |
| 432 | -7x | +|||
| 40 | +
- type = "response",+ |
|||
| 433 | -7x | +|||
| 41 | +
- offset = 0,+ # defaults |
|||
| 434 | -7x | +42 | +128x |
- weights = weights+ val <- x_stats[[stat]] |
| 435 | -+ | |||
| 43 | +128x |
- )+ na_str <- "NE" |
||
| 436 | +44 | |||
| 437 | -7x | +45 | +128x |
- list(+ if (imp_rule == "1/3") {
|
| 438 | -7x | +46 | +2x |
- glm_fit = glm_fit,+ if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT |
| 439 | -7x | +47 | +84x |
- emmeans_fit = emmeans_fit+ if (ltr_blq_ratio > 1 / 3) {
|
| 440 | -+ | |||
| 48 | +63x |
- )+ if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT |
||
| 441 | -+ | |||
| 49 | +9x |
- }+ if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
|
||
| 442 | -+ | |||
| 50 | +39x |
-
+ if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
|
||
| 443 | +51 |
- # h_ppmeans --------------------------------------------------------------------+ } |
||
| 444 | -+ | |||
| 52 | +44x |
- #' Function to return the estimated means using predicted probabilities- |
- ||
| 445 | -- |
- #'- |
- ||
| 446 | -- |
- #' @description- |
- ||
| 447 | -- |
- #' For each arm level, the predicted mean rate is calculated using the fitted model object, with `newdata`- |
- ||
| 448 | -- |
- #' set to the result of `stats::model.frame`, a reconstructed data or the original data, depending on the- |
- ||
| 449 | -- |
- #' object formula (coming from the fit). The confidence interval is derived using the `conf_level` parameter.- |
- ||
| 450 | -- |
- #'- |
- ||
| 451 | -- |
- #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm.- |
- ||
| 452 | -- |
- #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called in `.var` and `variables`.- |
- ||
| 453 | -- |
- #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be- |
- ||
| 454 | -- |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.- |
- ||
| 455 | -- |
- #' @param conf_level (`proportion`)\cr value used to derive the confidence interval for the rate.- |
- ||
| 456 | -- |
- #'- |
- ||
| 457 | -- |
- #' @return- |
- ||
| 458 | -- |
- #' * `h_ppmeans()` returns the estimated means.- |
- ||
| 459 | -- |
- #'- |
- ||
| 460 | -- |
- #' @seealso [summarize_glm_count()].- |
- ||
| 461 | -- |
- #'- |
- ||
| 462 | -- |
- #' @export- |
- ||
| 463 | -- |
- h_ppmeans <- function(obj, .df_row, arm, conf_level) {
- |
- ||
| 464 | -1x | -
- alpha <- 1 - conf_level- |
- ||
| 465 | -1x | -
- p <- 1 - alpha / 2- |
- ||
| 466 | -- | - - | -||
| 467 | -1x | -
- arm_levels <- levels(.df_row[[arm]])- |
- ||
| 468 | -- | - - | -||
| 469 | -1x | -
- out <- lapply(arm_levels, function(lev) {
- |
- ||
| 470 | -3x | -
- temp <- .df_row- |
- ||
| 471 | -3x | -
- temp[[arm]] <- factor(lev, levels = arm_levels)- |
- ||
| 472 | -- | - - | -||
| 473 | -3x | -
- mf <- stats::model.frame(obj$formula, data = temp)- |
- ||
| 474 | -3x | -
- X <- stats::model.matrix(obj$formula, data = mf) # nolint- |
- ||
| 475 | -- | - - | -||
| 476 | -3x | -
- rate <- stats::predict(obj, newdata = mf, type = "response")+ } else if (imp_rule == "1/2") {
|
||
| 477 | -3x | -
- rate_hat <- mean(rate)- |
- ||
| 478 | -- | - - | -||
| 479 | -3x | -
- zz <- colMeans(rate * X)- |
- ||
| 480 | -3x | +53 | +44x |
- se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz))+ if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
|
| 481 | -3x | +54 | +12x |
- rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat)+ val <- NA # 1/2_GT |
| 482 | -3x | +55 | +12x |
- rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat)+ na_str <- "ND" # 1/2_GT |
| 483 | +56 | - - | -||
| 484 | -3x | -
- c(rate_hat, rate_lwr, rate_upr)+ } |
||
| 485 | +57 |
- })+ } |
||
| 486 | +58 | |||
| 487 | -1x | -
- names(out) <- arm_levels- |
- ||
| 488 | -1x | -
- out <- do.call(rbind, out)- |
- ||
| 489 | -1x | -
- if ("negbin" %in% class(obj)) {
- |
- ||
| 490 | -! | -
- colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
- |
- ||
| 491 | -- |
- } else {
- |
- ||
| 492 | -1x | -
- colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
- |
- ||
| 493 | -- |
- }- |
- ||
| 494 | -1x | -
- out <- as.data.frame(out)- |
- ||
| 495 | -1x | -
- out[[arm]] <- rownames(out)- |
- ||
| 496 | -1x | +59 | +128x |
- out+ list(val = val, na_str = na_str) |
| 497 | +60 |
}@@ -44074,14 +43068,14 @@ tern coverage - 95.65% |
| 1 |
- #' Line plot with optional table+ #' Proportion estimation |
||
| 5 |
- #' Line plot with optional table.+ #' The analyze function [estimate_proportion()] creates a layout element to estimate the proportion of responders |
||
| 6 |
- #'+ #' within a studied population. The primary analysis variable, `vars`, indicates whether a response has occurred for |
||
| 7 |
- #' @inheritParams argument_convention+ #' each record. See the `method` parameter for options of methods to use when constructing the confidence interval of |
||
| 8 |
- #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only)+ #' the proportion. Additionally, a stratification variable can be supplied via the `strata` element of the `variables` |
||
| 9 |
- #' to counts objects in groups for stratification.+ #' argument. |
||
| 10 |
- #' @param variables (named `character`) vector of variable names in `df` which should include:+ #' |
||
| 11 |
- #' * `x` (`string`)\cr name of x-axis variable.+ #' @inheritParams prop_strat_wilson |
||
| 12 |
- #' * `y` (`string`)\cr name of y-axis variable.+ #' @inheritParams argument_convention |
||
| 13 |
- #' * `group_var` (`string` or `NULL`)\cr name of grouping variable (or strata), i.e. treatment arm.+ #' @param method (`string`)\cr the method used to construct the confidence interval |
||
| 14 |
- #' Can be `NA` to indicate lack of groups.+ #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`, |
||
| 15 |
- #' * `subject_var` (`string` or `NULL`)\cr name of subject variable. Only applies if `group_var` is+ #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`. |
||
| 16 |
- #' not NULL.+ #' @param long (`flag`)\cr whether a long description is required. |
||
| 17 |
- #' * `paramcd` (`string` or `NA`)\cr name of the variable for parameter's code. Used for y-axis label and plot's+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 18 |
- #' subtitle. Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle.+ #' |
||
| 19 |
- #' * `y_unit` (`string` or `NA`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.+ #' Options are: ``r shQuote(get_stats("estimate_proportion"))``
|
||
| 20 |
- #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle.+ #' |
||
| 21 |
- #' * `facet_var` (`string` or `NA`)\cr name of the secondary grouping variable used for plot faceting, i.e. treatment+ #' @seealso [h_proportions] |
||
| 22 |
- #' arm. Can be `NA` to indicate lack of groups.+ #' |
||
| 23 |
- #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.+ #' @name estimate_proportion |
||
| 24 |
- #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,+ #' @order 1 |
||
| 25 |
- #' and be of a `double` or `numeric` type vector of length one.+ NULL |
||
| 26 |
- #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.+ |
||
| 27 |
- #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,+ #' @describeIn estimate_proportion Statistics function estimating a |
||
| 28 |
- #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be+ #' proportion along with its confidence interval. |
||
| 29 |
- #' added to the plot.+ #' |
||
| 30 |
- #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names+ #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used, |
||
| 31 |
- #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of+ #' it indicates whether each subject is a responder or not. `TRUE` represents |
||
| 32 |
- #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting+ #' a successful outcome. If a `data.frame` is provided, also the `strata` variable |
||
| 33 |
- #' `interval = NULL`.+ #' names must be provided in `variables` as a list element with the strata strings. |
||
| 34 |
- #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.+ #' In the case of `data.frame`, the logical vector of responses must be indicated as a |
||
| 35 |
- #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`.+ #' variable name in `.var`. |
||
| 36 |
- #' @param sfun (`function`)\cr the function to compute the values of required statistics. It must return a named `list`+ #' |
||
| 37 |
- #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,+ #' @return |
||
| 38 |
- #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.+ #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a |
||
| 39 |
- #' @param ... optional arguments to `sfun`.+ #' given variable. |
||
| 40 |
- #' @param mid_type (`string`)\cr controls the type of the `mid` plot, it can be point (`"p"`), line (`"l"`),+ #' |
||
| 41 |
- #' or point and line (`"pl"`).+ #' @examples |
||
| 42 |
- #' @param mid_point_size (`numeric(1)`)\cr font size of the `mid` plot points.+ #' # Case with only logical vector. |
||
| 43 |
- #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of+ #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0) |
||
| 44 |
- #' a call to a position adjustment function.+ #' s_proportion(rsp_v) |
||
| 45 |
- #' @param legend_title (`string`)\cr legend title.+ #' |
||
| 46 |
- #' @param legend_position (`string`)\cr the position of the plot legend (`"none"`, `"left"`, `"right"`, `"bottom"`,+ #' # Example for Stratified Wilson CI |
||
| 47 |
- #' `"top"`, or a two-element numeric vector).+ #' nex <- 100 # Number of example rows |
||
| 48 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ #' dta <- data.frame( |
||
| 49 |
- #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
||
| 50 |
- #' between ticks on the x-axis, for use when `variables$x` is numeric. If `NULL` (default), [labeling::extended()] is+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
||
| 51 |
- #' used to determine optimal tick positions on the x-axis. If `variables$x` is not numeric, this argument is ignored.+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 52 |
- #' @param x_lab (`string` or `NULL`)\cr x-axis label. If `NULL` then no label will be added.+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
||
| 53 |
- #' @param y_lab (`string` or `NULL`)\cr y-axis label. If `NULL` then no label will be added.+ #' stringsAsFactors = TRUE |
||
| 54 |
- #' @param y_lab_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be added+ #' ) |
||
| 55 |
- #' to the y-axis label (`y_lab`).+ #' |
||
| 56 |
- #' @param y_lab_add_unit (`flag`)\cr whether y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be added+ #' s_proportion( |
||
| 57 |
- #' to the y-axis label (`y_lab`).+ #' df = dta, |
||
| 58 |
- #' @param title (`string`)\cr plot title.+ #' .var = "rsp", |
||
| 59 |
- #' @param subtitle (`string`)\cr plot subtitle.+ #' variables = list(strata = c("f1", "f2")),
|
||
| 60 |
- #' @param subtitle_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be+ #' conf_level = 0.90, |
||
| 61 |
- #' added to the plot's subtitle (`subtitle`).+ #' method = "strat_wilson" |
||
| 62 |
- #' @param subtitle_add_unit (`flag`)\cr whether the y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be+ #' ) |
||
| 63 |
- #' added to the plot's subtitle (`subtitle`).+ #' |
||
| 64 |
- #' @param caption (`string`)\cr optional caption below the plot.+ #' @export |
||
| 65 |
- #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the+ s_proportion <- function(df, |
||
| 66 |
- #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`+ .var, |
||
| 67 |
- #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.+ conf_level = 0.95, |
||
| 68 |
- #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table+ method = c( |
||
| 69 |
- #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.+ "waldcc", "wald", "clopper-pearson", |
||
| 70 |
- #' @param table_font_size (`numeric(1)`)\cr font size of the text in the table.+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
||
| 71 |
- #' @param newpage `r lifecycle::badge("deprecated")` not used.
+ "agresti-coull", "jeffreys" |
||
| 72 |
- #' @param col (`character`)\cr color(s). See `?ggplot2::aes_colour_fill_alpha` for example values.+ ), |
||
| 73 |
- #' @param linetype (`character`)\cr line type(s). See `?ggplot2::aes_linetype_size_shape` for example values.+ weights = NULL, |
||
| 74 |
- #' @param errorbar_width (`numeric(1)`)\cr width of the error bars.+ max_iterations = 50, |
||
| 75 |
- #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the line plot.+ variables = list(strata = NULL), |
||
| 76 |
- #' Relative height of annotation table is then `1 - rel_height_plot`. If `table = NULL`, this parameter is ignored.+ long = FALSE) {
|
||
| 77 | -+ | 167x |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `table` is not `NULL`.+ method <- match.arg(method) |
| 78 | -+ | 167x |
- #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the+ checkmate::assert_flag(long) |
| 79 | -+ | 167x |
- #' annotation table is printed below the plot via [cowplot::plot_grid()].+ assert_proportion_value(conf_level) |
| 80 |
- #'+ |
||
| 81 | -+ | 167x |
- #' @return A `ggplot` line plot (and statistics table if applicable).+ if (!is.null(variables$strata)) {
|
| 82 |
- #'+ # Checks for strata |
||
| 83 | -+ | ! |
- #' @examples+ if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
|
| 84 | -+ | ! |
- #'+ strata_colnames <- variables$strata |
| 85 | -+ | ! |
- #' adsl <- tern_ex_adsl+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
| 86 | -+ | ! |
- #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
| 87 | -+ | ! |
- #' adlb$AVISIT <- droplevels(adlb$AVISIT)+ assert_df_with_variables(df, strata_vars) |
| 88 |
- #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))+ |
||
| 89 | -+ | ! |
- #'+ strata <- interaction(df[strata_colnames]) |
| 90 | -+ | ! |
- #' # Mean with CI+ strata <- as.factor(strata) |
| 91 |
- #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")+ |
||
| 92 |
- #'+ # Pushing down checks to prop_strat_wilson |
||
| 93 | -+ | 167x |
- #' # Mean with CI, no stratification with group_var+ } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
|
| 94 | -+ | ! |
- #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA))+ stop("To use stratified methods you need to specify the strata variables.")
|
| 95 |
- #'+ } |
||
| 96 | -+ | 167x |
- #' # Mean, upper whisker of CI, no group_var(strata) counts N+ if (checkmate::test_atomic_vector(df)) {
|
| 97 | -+ | 167x |
- #' g_lineplot(+ rsp <- as.logical(df) |
| 98 |
- #' adlb,+ } else {
|
||
| 99 | -+ | ! |
- #' whiskers = "mean_ci_upr",+ rsp <- as.logical(df[[.var]]) |
| 100 |
- #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit"+ } |
||
| 101 | -+ | 167x |
- #' )+ n <- sum(rsp) |
| 102 | -+ | 167x |
- #'+ p_hat <- mean(rsp) |
| 103 |
- #' # Median with CI+ |
||
| 104 | -+ | 167x |
- #' g_lineplot(+ prop_ci <- switch(method, |
| 105 | -+ | 167x |
- #' adlb,+ "clopper-pearson" = prop_clopper_pearson(rsp, conf_level), |
| 106 | -+ | 167x |
- #' adsl,+ "wilson" = prop_wilson(rsp, conf_level), |
| 107 | -+ | 167x |
- #' mid = "median",+ "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE), |
| 108 | -+ | 167x |
- #' interval = "median_ci",+ "strat_wilson" = prop_strat_wilson(rsp, |
| 109 | -+ | 167x |
- #' whiskers = c("median_ci_lwr", "median_ci_upr"),
+ strata, |
| 110 | -+ | 167x |
- #' title = "Plot of Median and 95% Confidence Limits by Visit"+ weights, |
| 111 | -+ | 167x |
- #' )+ conf_level, |
| 112 | -+ | 167x |
- #'+ max_iterations, |
| 113 | -+ | 167x |
- #' # Mean, +/- SD+ correct = FALSE |
| 114 | -+ | 167x |
- #' g_lineplot(adlb, adsl,+ )$conf_int, |
| 115 | -+ | 167x |
- #' interval = "mean_sdi",+ "strat_wilsonc" = prop_strat_wilson(rsp, |
| 116 | -+ | 167x |
- #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
+ strata, |
| 117 | -+ | 167x |
- #' title = "Plot of Median +/- SD by Visit"+ weights, |
| 118 | -+ | 167x |
- #' )+ conf_level, |
| 119 | -+ | 167x |
- #'+ max_iterations, |
| 120 | -+ | 167x |
- #' # Mean with CI plot with stats table+ correct = TRUE |
| 121 | -+ | 167x |
- #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
+ )$conf_int, |
| 122 | -+ | 167x |
- #'+ "wald" = prop_wald(rsp, conf_level), |
| 123 | -+ | 167x |
- #' # Mean with CI, table and customized confidence level+ "waldcc" = prop_wald(rsp, conf_level, correct = TRUE), |
| 124 | -+ | 167x |
- #' g_lineplot(+ "agresti-coull" = prop_agresti_coull(rsp, conf_level), |
| 125 | -+ | 167x |
- #' adlb,+ "jeffreys" = prop_jeffreys(rsp, conf_level) |
| 126 |
- #' adsl,+ ) |
||
| 127 |
- #' table = c("n", "mean", "mean_ci"),
+
|
||
| 128 | -+ | 167x |
- #' control = control_analyze_vars(conf_level = 0.80),+ list( |
| 129 | -+ | 167x |
- #' title = "Plot of Mean and 80% Confidence Limits by Visit"+ "n_prop" = formatters::with_label(c(n, p_hat), "Responders"), |
| 130 | -+ | 167x |
- #' )+ "prop_ci" = formatters::with_label( |
| 131 | -+ | 167x |
- #'+ x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long) |
| 132 |
- #' # Mean with CI, table, filtered data+ ) |
||
| 133 |
- #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE")+ ) |
||
| 134 |
- #' g_lineplot(adlb_f, table = c("n", "mean"))
+ } |
||
| 135 |
- #'+ |
||
| 136 |
- #' @export+ #' @describeIn estimate_proportion Formatted analysis function which is used as `afun` |
||
| 137 |
- g_lineplot <- function(df,+ #' in `estimate_proportion()`. |
||
| 138 |
- alt_counts_df = NULL,+ #' |
||
| 139 |
- variables = control_lineplot_vars(),+ #' @return |
||
| 140 |
- mid = "mean",+ #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 141 |
- interval = "mean_ci",+ #' |
||
| 142 |
- whiskers = c("mean_ci_lwr", "mean_ci_upr"),
+ #' @export |
||
| 143 |
- table = NULL,+ a_proportion <- make_afun( |
||
| 144 |
- sfun = s_summary,+ s_proportion, |
||
| 145 |
- ...,+ .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)") |
||
| 146 |
- mid_type = "pl",+ ) |
||
| 147 |
- mid_point_size = 2,+ |
||
| 148 |
- position = ggplot2::position_dodge(width = 0.4),+ #' @describeIn estimate_proportion Layout-creating function which can take statistics function arguments |
||
| 149 |
- legend_title = NULL,+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 150 |
- legend_position = "bottom",+ #' |
||
| 151 |
- ggtheme = nestcolor::theme_nest(),+ #' @return |
||
| 152 |
- xticks = NULL,+ #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions, |
||
| 153 |
- xlim = NULL,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 154 |
- ylim = NULL,+ #' the statistics from `s_proportion()` to the table layout. |
||
| 155 |
- x_lab = obj_label(df[[variables[["x"]]]]),+ #' |
||
| 156 |
- y_lab = NULL,+ #' @examples |
||
| 157 |
- y_lab_add_paramcd = TRUE,+ #' dta_test <- data.frame( |
||
| 158 |
- y_lab_add_unit = TRUE,+ #' USUBJID = paste0("S", 1:12),
|
||
| 159 |
- title = "Plot of Mean and 95% Confidence Limits by Visit",+ #' ARM = rep(LETTERS[1:3], each = 4), |
||
| 160 |
- subtitle = "",+ #' AVAL = rep(LETTERS[1:3], each = 4) |
||
| 161 |
- subtitle_add_paramcd = TRUE,+ #' ) |
||
| 162 |
- subtitle_add_unit = TRUE,+ #' |
||
| 163 |
- caption = NULL,+ #' basic_table() %>% |
||
| 164 |
- table_format = NULL,+ #' split_cols_by("ARM") %>%
|
||
| 165 |
- table_labels = NULL,+ #' estimate_proportion(vars = "AVAL") %>% |
||
| 166 |
- table_font_size = 3,+ #' build_table(df = dta_test) |
||
| 167 |
- errorbar_width = 0.45,+ #' |
||
| 168 |
- newpage = lifecycle::deprecated(),+ #' @export |
||
| 169 |
- col = NULL,+ #' @order 2 |
||
| 170 |
- linetype = NULL,+ estimate_proportion <- function(lyt, |
||
| 171 |
- rel_height_plot = 0.5,+ vars, |
||
| 172 |
- as_list = FALSE) {
+ conf_level = 0.95, |
||
| 173 | -13x | +
- checkmate::assert_character(variables, any.missing = TRUE)+ method = c( |
|
| 174 | -13x | +
- checkmate::assert_character(mid, null.ok = TRUE)+ "waldcc", "wald", "clopper-pearson", |
|
| 175 | -13x | +
- checkmate::assert_character(interval, null.ok = TRUE)+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
|
| 176 | -13x | +
- checkmate::assert_character(col, null.ok = TRUE)+ "agresti-coull", "jeffreys" |
|
| 177 | -13x | +
- checkmate::assert_character(linetype, null.ok = TRUE)+ ), |
|
| 178 | -13x | +
- checkmate::assert_numeric(xticks, null.ok = TRUE)+ weights = NULL, |
|
| 179 | -13x | +
- checkmate::assert_numeric(xlim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ max_iterations = 50, |
|
| 180 | -13x | +
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ variables = list(strata = NULL), |
|
| 181 | -13x | +
- checkmate::assert_number(errorbar_width, lower = 0)+ long = FALSE, |
|
| 182 | -13x | +
- checkmate::assert_string(title, null.ok = TRUE)+ na_str = default_na_str(), |
|
| 183 | -13x | +
- checkmate::assert_string(subtitle, null.ok = TRUE)+ nested = TRUE, |
|
| 184 | -13x | +
- assert_proportion_value(rel_height_plot)+ ..., |
|
| 185 | -13x | +
- checkmate::assert_logical(as_list)+ show_labels = "hidden", |
|
| 186 |
-
+ table_names = vars, |
||
| 187 | -13x | +
- if (!is.null(table)) {
+ .stats = NULL, |
|
| 188 | -5x | +
- table_format <- get_formats_from_stats(table)+ .formats = NULL, |
|
| 189 | -5x | +
- table_labels <- get_labels_from_stats(table)+ .labels = NULL, |
|
| 190 |
- }+ .indent_mods = NULL) {
|
||
| 191 | -+ | 3x |
-
+ extra_args <- list( |
| 192 | -13x | +3x |
- extra_args <- list(...)+ conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations, |
| 193 | -13x | +3x |
- if ("control" %in% names(extra_args)) {
+ variables = variables, long = long, ... |
| 194 | -4x | +
- if (!is.null(table) && all(table_labels == get_labels_from_stats(table))) {
+ ) |
|
| 195 | -3x | +
- table_labels <- table_labels %>% labels_use_control(extra_args[["control"]])+ |
|
| 196 | -+ | 3x |
- }+ afun <- make_afun( |
| 197 | -+ | 3x |
- }+ a_proportion, |
| 198 | -+ | 3x |
-
+ .stats = .stats, |
| 199 | -13x | +3x |
- if (is.character(interval)) {
+ .formats = .formats, |
| 200 | -13x | +3x |
- checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)+ .labels = .labels, |
| 201 | -+ | 3x |
- }+ .indent_mods = .indent_mods |
| 202 |
-
+ ) |
||
| 203 | -13x | +3x |
- if (length(whiskers) == 1) {
+ analyze( |
| 204 | -! | +3x |
- checkmate::assert_character(mid)+ lyt, |
| 205 | -+ | 3x |
- }+ vars, |
| 206 | -+ | 3x |
-
+ afun = afun, |
| 207 | -13x | +3x |
- if (is.character(mid)) {
+ na_str = na_str, |
| 208 | -13x | +3x |
- checkmate::assert_scalar(mid_type)+ nested = nested, |
| 209 | -13x | +3x |
- checkmate::assert_subset(mid_type, c("pl", "p", "l"))
+ extra_args = extra_args, |
| 210 | -+ | 3x |
- }+ show_labels = show_labels, |
| 211 | -+ | 3x |
-
+ table_names = table_names |
| 212 | -13x | +
- x <- variables[["x"]]+ ) |
|
| 213 | -13x | +
- y <- variables[["y"]]+ } |
|
| 214 | -13x | +
- paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables+ |
|
| 215 | -13x | +
- y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables+ #' Helper functions for calculating proportion confidence intervals |
|
| 216 | -13x | +
- if (is.na(variables["group_var"])) {
+ #' |
|
| 217 | -1x | +
- group_var <- NULL # NULL if group_var == NA or it is not in variables+ #' @description `r lifecycle::badge("stable")`
|
|
| 218 |
- } else {
+ #' |
||
| 219 | -12x | +
- group_var <- variables[["group_var"]]+ #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()]. |
|
| 220 | -12x | +
- subject_var <- variables[["subject_var"]]+ #' |
|
| 221 |
- }+ #' @inheritParams argument_convention |
||
| 222 | -13x | +
- if (is.na(variables["facet_var"])) {
+ #' @inheritParams estimate_proportion |
|
| 223 | -12x | +
- facet_var <- NULL # NULL if facet_var == NA or it is not in variables+ #' |
|
| 224 |
- } else {
+ #' @return Confidence interval of a proportion. |
||
| 225 | -1x | +
- facet_var <- variables[["facet_var"]]+ #' |
|
| 226 |
- }+ #' @seealso [estimate_proportion], descriptive function [d_proportion()], |
||
| 227 | -13x | +
- checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)+ #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()]. |
|
| 228 | -13x | +
- checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)+ #' |
|
| 229 | -13x | +
- if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
+ #' @name h_proportions |
|
| 230 | -13x | +
- checkmate::assert_false(is.na(paramcd))+ NULL |
|
| 231 | -13x | +
- checkmate::assert_scalar(unique(df[[paramcd]]))+ |
|
| 232 |
- }+ #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()]. |
||
| 233 |
-
+ #' Also referred to as Wilson score interval. |
||
| 234 | -13x | +
- checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)+ #' |
|
| 235 | -13x | +
- checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)+ #' @examples |
|
| 236 | -13x | +
- if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
+ #' rsp <- c( |
|
| 237 | -13x | +
- checkmate::assert_false(is.na(y_unit))+ #' TRUE, TRUE, TRUE, TRUE, TRUE, |
|
| 238 | -13x | +
- checkmate::assert_scalar(unique(df[[y_unit]]))+ #' FALSE, FALSE, FALSE, FALSE, FALSE |
|
| 239 |
- }+ #' ) |
||
| 240 |
-
+ #' prop_wilson(rsp, conf_level = 0.9) |
||
| 241 | -13x | +
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ #' |
|
| 242 | -8x | +
- checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]]))+ #' @export |
|
| 243 |
- }+ prop_wilson <- function(rsp, conf_level, correct = FALSE) {
|
||
| 244 | -+ | 5x |
-
+ y <- stats::prop.test( |
| 245 | -+ | 5x |
- ####################################### |+ sum(rsp), |
| 246 | -+ | 5x |
- # ---- Compute required statistics ----+ length(rsp), |
| 247 | -+ | 5x |
- ####################################### |+ correct = correct, |
| 248 | -+ | 5x |
- # Remove unused levels for x-axis+ conf.level = conf_level |
| 249 | -13x | +
- if (is.factor(df[[x]])) {
+ ) |
|
| 250 | -12x | +
- df[[x]] <- droplevels(df[[x]])+ |
|
| 251 | -+ | 5x |
- }+ as.numeric(y$conf.int) |
| 252 |
-
+ } |
||
| 253 | -13x | +
- if (!is.null(facet_var) && !is.null(group_var)) {
+
|
|
| 254 | -1x | +
- df_grp <- tidyr::expand(df, .data[[facet_var]], .data[[group_var]], .data[[x]]) # expand based on levels of factors+ #' @describeIn h_proportions Calculates the stratified Wilson confidence |
|
| 255 | -12x | +
- } else if (!is.null(group_var)) {
+ #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
|
|
| 256 | -11x | +
- df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors+ #' |
|
| 257 |
- } else {
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 258 | -1x | +
- df_grp <- tidyr::expand(df, NULL, .data[[x]])+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are |
|
| 259 |
- }+ #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
|
||
| 260 |
-
+ #' minimizes the weighted squared length of the confidence interval. |
||
| 261 | -13x | +
- df_grp <- df_grp %>%+ #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used |
|
| 262 | -13x | +
- dplyr::full_join(y = df[, c(facet_var, group_var, x, y)], by = c(facet_var, group_var, x), multiple = "all") %>%+ #' to find estimates of optimal weights. |
|
| 263 | -13x | +
- dplyr::group_by_at(c(facet_var, group_var, x))+ #' @param correct (`flag`)\cr whether to include the continuity correction. For further information, see for example |
|
| 264 |
-
+ #' for [stats::prop.test()]. |
||
| 265 | -13x | +
- df_stats <- df_grp %>%+ #' |
|
| 266 | -13x | +
- dplyr::summarise(+ #' @references |
|
| 267 | -13x | +
- data.frame(t(do.call(c, unname(sfun(.data[[y]])[c(mid, interval)])))),+ #' \insertRef{Yan2010-jt}{tern}
|
|
| 268 | -13x | +
- .groups = "drop"+ #' |
|
| 269 |
- )+ #' @examples |
||
| 270 |
-
+ #' # Stratified Wilson confidence interval with unequal probabilities |
||
| 271 | -13x | +
- df_stats <- df_stats[!is.na(df_stats[[mid]]), ]+ #' |
|
| 272 |
-
+ #' set.seed(1) |
||
| 273 |
- # add number of objects N in group_var (strata)+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
||
| 274 | -13x | +
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ #' strata_data <- data.frame( |
|
| 275 | -8x | +
- strata_N <- paste0(group_var, "_N") # nolint+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
|
| 276 |
-
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 277 | -8x | +
- 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+ #' stringsAsFactors = TRUE |
|
| 278 | -8x | +
- colnames(df_N) <- c(group_var, "N") # nolint+ #' ) |
|
| 279 | -8x | +
- df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint+ #' strata <- interaction(strata_data) |
|
| 280 |
-
+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata |
||
| 281 |
- # keep strata factor levels+ #' |
||
| 282 | -8x | +
- matches <- sapply(unique(df_N[[group_var]]), function(x) {
+ #' prop_strat_wilson( |
|
| 283 | -22x | +
- regex_pattern <- gsub("([][(){}^$.|*+?\\\\])", "\\\\\\1", x)
+ #' rsp = rsp, strata = strata, |
|
| 284 | -22x | +
- unique(df_N[[paste0(group_var, "_N")]])[grepl(+ #' conf_level = 0.90 |
|
| 285 | -22x | +
- paste0("^", regex_pattern),
+ #' ) |
|
| 286 | -22x | +
- unique(df_N[[paste0(group_var, "_N")]])+ #' |
|
| 287 |
- )]+ #' # Not automatic setting of weights |
||
| 288 |
- })+ #' prop_strat_wilson( |
||
| 289 | -8x | +
- df_N[[paste0(group_var, "_N")]] <- factor(df_N[[group_var]]) # nolint+ #' rsp = rsp, strata = strata, |
|
| 290 | -8x | +
- levels(df_N[[paste0(group_var, "_N")]]) <- unlist(matches) # nolint+ #' weights = rep(1 / n_strata, n_strata), |
|
| 291 |
-
+ #' conf_level = 0.90 |
||
| 292 |
- # strata_N should not be in colnames(df_stats)+ #' ) |
||
| 293 | -8x | +
- checkmate::assert_disjunct(strata_N, colnames(df_stats))+ #' |
|
| 294 |
-
+ #' @export |
||
| 295 | -8x | +
- df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var)+ prop_strat_wilson <- function(rsp, |
|
| 296 | -5x | +
- } else if (!is.null(group_var)) {
+ strata, |
|
| 297 | -4x | +
- strata_N <- group_var # nolint+ weights = NULL, |
|
| 298 |
- } else {
+ conf_level = 0.95, |
||
| 299 | -1x | +
- strata_N <- NULL # nolint+ max_iterations = NULL, |
|
| 300 |
- }+ correct = FALSE) {
|
||
| 301 | -+ | 20x |
-
+ checkmate::assert_logical(rsp, any.missing = FALSE) |
| 302 | -+ | 20x |
- ############################################### |+ checkmate::assert_factor(strata, len = length(rsp)) |
| 303 | -+ | 20x |
- # ---- Prepare certain plot's properties. ----+ assert_proportion_value(conf_level) |
| 304 |
- ############################################### |+ |
||
| 305 | -+ | 20x |
- # legend title+ tbl <- table(rsp, strata) |
| 306 | -13x | +20x |
- if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
+ n_strata <- length(unique(strata)) |
| 307 | -12x | +
- legend_title <- attr(df[[group_var]], "label")+ |
|
| 308 |
- }+ # Checking the weights and maximum number of iterations. |
||
| 309 | -+ | 20x |
-
+ do_iter <- FALSE |
| 310 | -+ | 20x |
- # y label+ if (is.null(weights)) {
|
| 311 | -13x | +6x |
- if (!is.null(y_lab)) {
+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
| 312 | -4x | +6x |
- if (y_lab_add_paramcd) {
+ do_iter <- TRUE |
| 313 | -4x | +
- y_lab <- paste(y_lab, unique(df[[paramcd]]))+ |
|
| 314 |
- }+ # Iteration parameters |
||
| 315 | -+ | 2x |
-
+ if (is.null(max_iterations)) max_iterations <- 10 |
| 316 | -4x | +6x |
- if (y_lab_add_unit) {
+ checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1) |
| 317 | -4x | +
- y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
+ } |
|
| 318 | -+ | 20x |
- }+ checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata) |
| 319 | -+ | 20x |
-
+ sum_weights <- checkmate::assert_int(sum(weights)) |
| 320 | -4x | +! |
- y_lab <- trimws(y_lab)+ if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
|
| 321 |
- }+ |
||
| 322 | -+ | 20x |
-
+ xs <- tbl["TRUE", ] |
| 323 | -+ | 20x |
- # subtitle+ ns <- colSums(tbl) |
| 324 | -13x | +20x |
- if (!is.null(subtitle)) {
+ use_stratum <- (ns > 0) |
| 325 | -13x | +20x |
- if (subtitle_add_paramcd) {
+ ns <- ns[use_stratum] |
| 326 | -13x | +20x |
- subtitle <- paste(subtitle, unique(df[[paramcd]]))+ xs <- xs[use_stratum] |
| 327 | -+ | 20x |
- }+ ests <- xs / ns |
| 328 | -+ | 20x |
-
+ vars <- ests * (1 - ests) / ns |
| 329 | -13x | +
- if (subtitle_add_unit) {
+
|
|
| 330 | -13x | +20x |
- subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
+ strata_qnorm <- strata_normal_quantile(vars, weights, conf_level) |
| 331 |
- }+ |
||
| 332 |
-
+ # Iterative setting of weights if they were not set externally |
||
| 333 | -13x | +20x |
- subtitle <- trimws(subtitle)+ weights_new <- if (do_iter) {
|
| 334 | -+ | 6x |
- }+ update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights |
| 335 |
-
+ } else {
|
||
| 336 | -+ | 14x |
- ############################### |+ weights |
| 337 |
- # ---- Build plot object. ----+ } |
||
| 338 |
- ############################### |+ |
||
| 339 | -13x | +20x |
- p <- ggplot2::ggplot(+ strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1 |
| 340 | -13x | +
- data = df_stats,+ |
|
| 341 | -13x | +20x |
- mapping = ggplot2::aes(+ ci_by_strata <- Map( |
| 342 | -13x | +20x |
- x = .data[[x]], y = .data[[mid]],+ function(x, n) {
|
| 343 | -13x | +
- color = if (is.null(strata_N)) NULL else .data[[strata_N]],+ # Classic Wilson's confidence interval |
|
| 344 | -13x | +139x |
- shape = if (is.null(strata_N)) NULL else .data[[strata_N]],+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int) |
| 345 | -13x | +
- lty = if (is.null(strata_N)) NULL else .data[[strata_N]],+ }, |
|
| 346 | -13x | +20x |
- group = if (is.null(strata_N)) NULL else .data[[strata_N]]+ x = xs, |
| 347 | -+ | 20x |
- )+ n = ns |
| 349 | -+ | 20x |
-
+ lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
| 350 | -13x | +20x |
- if (!is.null(group_var) && nlevels(df_stats[[strata_N]]) > 6) {
+ upper_by_strata <- sapply(ci_by_strata, "[", 2L) |
| 351 | -1x | +
- p <- p ++ |
|
| 352 | -1x | +20x |
- scale_shape_manual(values = seq(15, 15 + nlevels(df_stats[[strata_N]])))+ lower <- sum(weights_new * lower_by_strata) |
| 353 | -+ | 20x |
- }+ upper <- sum(weights_new * upper_by_strata) |
| 355 | -13x | +
- if (!is.null(mid)) {
+ # Return values |
|
| 356 | -+ | 20x |
- # points+ if (do_iter) {
|
| 357 | -13x | +6x |
- if (grepl("p", mid_type, fixed = TRUE)) {
+ list( |
| 358 | -13x | +6x |
- p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)+ conf_int = c( |
| 359 | -+ | 6x |
- }+ lower = lower, |
| 360 | -+ | 6x |
-
+ upper = upper |
| 361 |
- # lines - plotted only if there is a strata grouping (group_var)+ ), |
||
| 362 | -13x | +6x |
- if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata_N)) { # nolint
+ weights = weights_new |
| 363 | -12x | +
- p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)+ ) |
|
| 364 |
- }+ } else {
|
||
| 365 | -+ | 14x |
- }+ list( |
| 366 | -+ | 14x |
-
+ conf_int = c( |
| 367 | -+ | 14x |
- # interval+ lower = lower, |
| 368 | -13x | +14x |
- if (!is.null(interval)) {
+ upper = upper |
| 369 | -13x | +
- p <- p ++ ) |
|
| 370 | -13x | +
- ggplot2::geom_errorbar(+ ) |
|
| 371 | -13x | +
- ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),+ } |
|
| 372 | -13x | +
- width = errorbar_width,+ } |
|
| 373 | -13x | +
- position = position+ |
|
| 374 |
- )+ #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
||
| 375 |
-
+ #' Also referred to as the `exact` method. |
||
| 376 | -13x | +
- if (length(whiskers) == 1) { # lwr or upr only; mid is then required
+ #' |
|
| 377 |
- # workaround as geom_errorbar does not provide single-direction whiskers+ #' @examples |
||
| 378 | -! | +
- p <- p ++ #' prop_clopper_pearson(rsp, conf_level = .95) |
|
| 379 | -! | +
- ggplot2::geom_linerange(+ #' |
|
| 380 | -! | +
- data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings+ #' @export |
|
| 381 | -! | +
- ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),+ prop_clopper_pearson <- function(rsp, |
|
| 382 | -! | +
- position = position,+ conf_level) {
|
|
| 383 | -! | +1x |
- na.rm = TRUE,+ y <- stats::binom.test( |
| 384 | -! | +1x |
- show.legend = FALSE+ x = sum(rsp), |
| 385 | -+ | 1x |
- )+ n = length(rsp), |
| 386 | -+ | 1x |
- }+ conf.level = conf_level |
| 387 |
- }+ ) |
||
| 388 | -+ | 1x |
-
+ as.numeric(y$conf.int) |
| 389 | -13x | +
- if (is.numeric(df_stats[[x]])) {
+ } |
|
| 390 | -1x | +
- if (length(xticks) == 1) xticks <- seq(from = min(df_stats[[x]]), to = max(df_stats[[x]]), by = xticks)+ |
|
| 391 | -1x | +
- p <- p + ggplot2::scale_x_continuous(breaks = if (!is.null(xticks)) xticks else waiver(), limits = xlim)+ #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition |
|
| 392 |
- }+ #' for a single proportion confidence interval using the normal approximation. |
||
| 393 |
-
+ #' |
||
| 394 | -13x | +
- p <- p ++ #' @param correct (`flag`)\cr whether to apply continuity correction. |
|
| 395 | -13x | +
- ggplot2::scale_y_continuous(labels = scales::comma, limits = ylim) ++ #' |
|
| 396 | -13x | +
- ggplot2::labs(+ #' @examples |
|
| 397 | -13x | +
- title = title,+ #' prop_wald(rsp, conf_level = 0.95) |
|
| 398 | -13x | +
- subtitle = subtitle,+ #' prop_wald(rsp, conf_level = 0.95, correct = TRUE) |
|
| 399 | -13x | +
- caption = caption,+ #' |
|
| 400 | -13x | +
- color = legend_title,+ #' @export |
|
| 401 | -13x | +
- lty = legend_title,+ prop_wald <- function(rsp, conf_level, correct = FALSE) {
|
|
| 402 | -13x | +163x |
- shape = legend_title,+ n <- length(rsp) |
| 403 | -13x | +163x |
- x = x_lab,+ p_hat <- mean(rsp) |
| 404 | -13x | +163x |
- y = y_lab+ z <- stats::qnorm((1 + conf_level) / 2) |
| 405 | -+ | 163x |
- )+ q_hat <- 1 - p_hat |
| 406 | -+ | 163x |
-
+ correct <- if (correct) 1 / (2 * n) else 0 |
| 407 | -13x | +
- if (!is.null(col)) {
+
|
|
| 408 | -1x | +163x |
- p <- p ++ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct |
| 409 | -1x | +163x |
- ggplot2::scale_color_manual(values = col)+ l_ci <- max(0, p_hat - err) |
| 410 | -+ | 163x |
- }+ u_ci <- min(1, p_hat + err) |
| 411 | -13x | +
- if (!is.null(linetype)) {
+
|
|
| 412 | -1x | +163x |
- p <- p ++ c(l_ci, u_ci) |
| 413 | -1x | +
- ggplot2::scale_linetype_manual(values = linetype)+ } |
|
| 414 |
- }+ |
||
| 415 |
-
+ #' @describeIn h_proportions Calculates the Agresti-Coull interval. Constructed (for 95% CI) by adding two successes |
||
| 416 | -13x | +
- if (!is.null(facet_var)) {
+ #' and two failures to the data and then using the Wald formula to construct a CI. |
|
| 417 | -1x | +
- p <- p ++ #' |
|
| 418 | -1x | +
- facet_grid(cols = vars(df_stats[[facet_var]]))+ #' @examples |
|
| 419 |
- }+ #' prop_agresti_coull(rsp, conf_level = 0.95) |
||
| 420 |
-
+ #' |
||
| 421 | -13x | +
- if (!is.null(ggtheme)) {
+ #' @export |
|
| 422 | -13x | +
- p <- p + ggtheme+ prop_agresti_coull <- function(rsp, conf_level) {
|
|
| 423 | -+ | 3x |
- } else {
+ n <- length(rsp) |
| 424 | -! | +3x |
- p <- p ++ x_sum <- sum(rsp) |
| 425 | -! | +3x |
- ggplot2::theme_bw() ++ z <- stats::qnorm((1 + conf_level) / 2) |
| 426 | -! | +
- ggplot2::theme(+ |
|
| 427 | -! | +
- legend.key.width = grid::unit(1, "cm"),+ # Add here both z^2 / 2 successes and failures. |
|
| 428 | -! | +3x |
- legend.position = legend_position,+ x_sum_tilde <- x_sum + z^2 / 2 |
| 429 | -! | +3x |
- legend.direction = ifelse(+ n_tilde <- n + z^2 |
| 430 | -! | +
- legend_position %in% c("top", "bottom"),
+
|
|
| 431 | -! | +
- "horizontal",+ # Then proceed as with the Wald interval. |
|
| 432 | -! | +3x |
- "vertical"+ p_tilde <- x_sum_tilde / n_tilde |
| 433 | -+ | 3x |
- )+ q_tilde <- 1 - p_tilde |
| 434 | -+ | 3x |
- )+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
| 435 | -+ | 3x |
- }+ l_ci <- max(0, p_tilde - err) |
| 436 | -+ | 3x |
-
+ u_ci <- min(1, p_tilde + err) |
| 437 |
- ############################################################# |+ |
||
| 438 | -+ | 3x |
- # ---- Optionally, add table to the bottom of the plot. ----+ c(l_ci, u_ci) |
| 439 |
- ############################################################# |+ } |
||
| 440 | -13x | +
- if (!is.null(table)) {
+
|
|
| 441 | -5x | +
- df_stats_table <- df_grp %>%+ #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the |
|
| 442 | -5x | +
- dplyr::summarise(+ #' non-informative Jeffreys prior for a binomial proportion. |
|
| 443 | -5x | +
- h_format_row(+ #' |
|
| 444 | -5x | +
- x = sfun(.data[[y]], ...)[table],+ #' @examples |
|
| 445 | -5x | +
- format = table_format,+ #' prop_jeffreys(rsp, conf_level = 0.95) |
|
| 446 | -5x | +
- labels = table_labels+ #' |
|
| 447 |
- ),+ #' @export |
||
| 448 | -5x | +
- .groups = "drop"+ prop_jeffreys <- function(rsp, |
|
| 449 |
- )+ conf_level) {
|
||
| 450 | -+ | 5x |
-
+ n <- length(rsp) |
| 451 | 5x |
- stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x)))+ x_sum <- sum(rsp) |
|
| 453 | 5x |
- df_stats_table <- df_stats_table %>%+ alpha <- 1 - conf_level |
|
| 454 | 5x |
- tidyr::pivot_longer(+ l_ci <- ifelse( |
|
| 455 | 5x |
- cols = -dplyr::all_of(c(group_var, x)),+ x_sum == 0, |
|
| 456 | 5x |
- names_to = "stat",+ 0, |
|
| 457 | 5x |
- values_to = "value",+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
|
| 458 | -5x | +
- names_ptypes = list(stat = factor(levels = stats_lev))+ ) |
|
| 459 |
- )+ |
||
| 460 | -+ | 5x |
-
+ u_ci <- ifelse( |
| 461 | 5x |
- tbl <- ggplot2::ggplot(+ x_sum == n, |
|
| 462 | 5x |
- df_stats_table,+ 1, |
|
| 463 | 5x |
- ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
|
| 464 |
- ) ++ ) |
||
| 465 | -5x | +
- ggplot2::geom_text(size = table_font_size) ++ |
|
| 466 | 5x |
- ggplot2::theme_bw() ++ c(l_ci, u_ci) |
|
| 467 | -5x | +
- ggplot2::theme(+ } |
|
| 468 | -5x | +
- panel.border = ggplot2::element_blank(),+ |
|
| 469 | -5x | +
- panel.grid.major = ggplot2::element_blank(),+ #' Description of the proportion summary |
|
| 470 | -5x | +
- panel.grid.minor = ggplot2::element_blank(),+ #' |
|
| 471 | -5x | +
- axis.ticks = ggplot2::element_blank(),+ #' @description `r lifecycle::badge("stable")`
|
|
| 472 | -5x | +
- axis.title = ggplot2::element_blank(),+ #' |
|
| 473 | -5x | +
- axis.text.x = ggplot2::element_blank(),+ #' This is a helper function that describes the analysis in [s_proportion()]. |
|
| 474 | -5x | +
- axis.text.y = ggplot2::element_text(+ #' |
|
| 475 | -5x | +
- size = table_font_size * ggplot2::.pt,+ #' @inheritParams s_proportion |
|
| 476 | -5x | +
- margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)+ #' @param long (`flag`)\cr whether a long or a short (default) description is required. |
|
| 477 |
- ),+ #' |
||
| 478 | -5x | +
- strip.text = ggplot2::element_text(hjust = 0),+ #' @return String describing the analysis. |
|
| 479 | -5x | +
- strip.text.x = ggplot2::element_text(+ #' |
|
| 480 | -5x | +
- size = table_font_size * ggplot2::.pt,+ #' @export |
|
| 481 | -5x | +
- margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")+ d_proportion <- function(conf_level, |
|
| 482 |
- ),+ method, |
||
| 483 | -5x | +
- strip.background = ggplot2::element_rect(fill = "grey95", color = NA),+ long = FALSE) {
|
|
| 484 | -5x | +179x |
- legend.position = "none"+ label <- paste0(conf_level * 100, "% CI") |
| 485 |
- )+ |
||
| 486 | -+ | ! |
-
+ if (long) label <- paste(label, "for Response Rates") |
| 487 | -5x | +
- if (!is.null(group_var)) {
+
|
|
| 488 | -5x | +179x |
- tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1)+ method_part <- switch(method, |
| 489 | -+ | 179x |
- }+ "clopper-pearson" = "Clopper-Pearson", |
| 490 | -+ | 179x |
-
+ "waldcc" = "Wald, with correction", |
| 491 | -5x | +179x |
- if (!as_list) {
+ "wald" = "Wald, without correction", |
| 492 | -+ | 179x |
- # align plot and table+ "wilson" = "Wilson, without correction", |
| 493 | -4x | +179x |
- cowplot::plot_grid(+ "strat_wilson" = "Stratified Wilson, without correction", |
| 494 | -4x | +179x |
- p,+ "wilsonc" = "Wilson, with correction", |
| 495 | -4x | +179x |
- tbl,+ "strat_wilsonc" = "Stratified Wilson, with correction", |
| 496 | -4x | +179x |
- ncol = 1,+ "agresti-coull" = "Agresti-Coull", |
| 497 | -4x | +179x |
- align = "v",+ "jeffreys" = "Jeffreys", |
| 498 | -4x | +179x |
- axis = "tblr",+ stop(paste(method, "does not have a description")) |
| 499 | -4x | +
- rel_heights = c(rel_height_plot, 1 - rel_height_plot)+ ) |
|
| 500 |
- )+ |
||
| 501 | -+ | 179x |
- } else {
+ paste0(label, " (", method_part, ")")
|
| 502 | -1x | +
- list(plot = p, table = tbl)+ } |
|
| 503 |
- }+ |
||
| 504 |
- } else {
+ #' Helper function for the estimation of stratified quantiles |
||
| 505 | -8x | +
- p+ #' |
|
| 506 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 507 |
- }+ #' |
||
| 508 |
-
+ #' This function wraps the estimation of stratified percentiles when we assume |
||
| 509 |
- #' Helper function to format the optional `g_lineplot` table+ #' the approximation for large numbers. This is necessary only in the case |
||
| 510 |
- #'+ #' proportions for each strata are unequal. |
||
| 511 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 512 |
- #'+ #' @inheritParams argument_convention |
||
| 513 |
- #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.+ #' @inheritParams prop_strat_wilson |
||
| 514 |
- #' Elements of `x` must be `numeric` vectors.+ #' |
||
| 515 |
- #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must+ #' @return Stratified quantile. |
||
| 516 |
- #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell`+ #' |
||
| 517 |
- #' function through the `format` parameter.+ #' @seealso [prop_strat_wilson()] |
||
| 518 |
- #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must+ #' |
||
| 519 |
- #' match the names of `x`. When a label is not specified for an element of `x`,+ #' @examples |
||
| 520 |
- #' then this function tries to use `label` or `names` (in this order) attribute of that element+ #' strata_data <- table(data.frame( |
||
| 521 |
- #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 522 |
- #' are attached to a given element of `x`, then the label is automatically generated.+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 523 |
- #'+ #' stringsAsFactors = TRUE |
||
| 524 |
- #' @return A single row `data.frame` object.+ #' )) |
||
| 525 |
- #'+ #' ns <- colSums(strata_data) |
||
| 526 |
- #' @examples+ #' ests <- strata_data["TRUE", ] / ns |
||
| 527 |
- #' mean_ci <- c(48, 51)+ #' vars <- ests * (1 - ests) / ns |
||
| 528 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ #' weights <- rep(1 / length(ns), length(ns)) |
||
| 529 |
- #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")+ #' |
||
| 530 |
- #' labels <- c(mean = "My Mean")+ #' strata_normal_quantile(vars, weights, 0.95) |
||
| 531 |
- #' h_format_row(x, format, labels)+ #' |
||
| 532 |
- #'+ #' @export |
||
| 533 |
- #' attr(mean_ci, "label") <- "Mean 95% CI"+ strata_normal_quantile <- function(vars, weights, conf_level) {
|
||
| 534 | -+ | 43x |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ summands <- weights^2 * vars |
| 535 |
- #' h_format_row(x, format, labels)+ # Stratified quantile |
||
| 536 | -+ | 43x |
- #'+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2) |
| 537 |
- #' @export+ } |
||
| 538 |
- h_format_row <- function(x, format, labels = NULL) {
+
|
||
| 539 |
- # cell: one row, one column data.frame+ #' Helper function for the estimation of weights for `prop_strat_wilson()` |
||
| 540 | -92x | +
- format_cell <- function(x, format, label = NULL) {
+ #' |
|
| 541 | -238x | +
- fc <- format_rcell(x = x, format = unlist(format))+ #' @description `r lifecycle::badge("stable")`
|
|
| 542 | -238x | +
- if (is.na(fc)) {
+ #' |
|
| 543 | -! | +
- fc <- "NA"+ #' This function wraps the iteration procedure that allows you to estimate |
|
| 544 |
- }+ #' the weights for each proportional strata. This assumes to minimize the |
||
| 545 | -238x | +
- x_label <- attr(x, "label")+ #' weighted squared length of the confidence interval. |
|
| 546 | -238x | +
- if (!is.null(label) && !is.na(label)) {
+ #' |
|
| 547 | -236x | +
- names(fc) <- label+ #' @inheritParams prop_strat_wilson |
|
| 548 | -2x | +
- } else if (!is.null(x_label) && !is.na(x_label)) {
+ #' @param vars (`numeric`)\cr normalized proportions for each strata. |
|
| 549 | -1x | +
- names(fc) <- x_label+ #' @param strata_qnorm (`numeric(1)`)\cr initial estimation with identical weights of the quantiles. |
|
| 550 | -1x | +
- } else if (length(x) == length(fc)) {
+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can |
|
| 551 | -! | +
- names(fc) <- names(x)+ #' be optimized in the future if we need to estimate better initial weights. |
|
| 552 |
- }+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata. |
||
| 553 | -238x | +
- as.data.frame(t(fc))+ #' @param max_iterations (`integer(1)`)\cr maximum number of iterations to be tried. Convergence is always checked. |
|
| 554 |
- }+ #' @param tol (`numeric(1)`)\cr tolerance threshold for convergence. |
||
| 555 |
-
+ #' |
||
| 556 | -92x | +
- row <- do.call(+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`. |
|
| 557 | -92x | +
- cbind,+ #' |
|
| 558 | -92x | +
- lapply(+ #' @seealso For references and details see [prop_strat_wilson()]. |
|
| 559 | -92x | +
- names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])+ #' |
|
| 560 |
- )+ #' @examples |
||
| 561 |
- )+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018) |
||
| 562 |
-
+ #' sq <- 0.674 |
||
| 563 | -92x | +
- row+ #' ws <- rep(1 / length(vs), length(vs)) |
|
| 564 |
- }+ #' ns <- c(22, 18, 17, 17, 14, 12) |
||
| 565 |
-
+ #' |
||
| 566 |
- #' Control function for `g_lineplot()`+ #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001) |
||
| 568 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 569 |
- #'+ update_weights_strat_wilson <- function(vars, |
||
| 570 |
- #' Default values for `variables` parameter in `g_lineplot` function.+ strata_qnorm, |
||
| 571 |
- #' A variable's default value can be overwritten for any variable.+ initial_weights, |
||
| 572 |
- #'+ n_per_strata, |
||
| 573 |
- #' @param x (`string`)\cr x-variable name.+ max_iterations = 50, |
||
| 574 |
- #' @param y (`string`)\cr y-variable name.+ conf_level = 0.95, |
||
| 575 |
- #' @param group_var (`string` or `NA`)\cr group variable name.+ tol = 0.001) {
|
||
| 576 | -+ | 9x |
- #' @param subject_var (`string` or `NA`)\cr subject variable name.+ it <- 0 |
| 577 | -+ | 9x |
- #' @param facet_var (`string` or `NA`)\cr faceting variable name.+ diff_v <- NULL |
| 578 |
- #' @param paramcd (`string` or `NA`)\cr parameter code variable name.+ |
||
| 579 | -+ | 9x |
- #' @param y_unit (`string` or `NA`)\cr y-axis unit variable name.+ while (it < max_iterations) {
|
| 580 | -+ | 21x |
- #'+ it <- it + 1 |
| 581 | -+ | 21x |
- #' @return A named character vector of variable names.+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2 |
| 582 | -+ | 21x |
- #'+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2)) |
| 583 | -+ | 21x |
- #' @examples+ weights_new <- weights_new_t / weights_new_b |
| 584 | -+ | 21x |
- #' control_lineplot_vars()+ weights_new <- weights_new / sum(weights_new) |
| 585 | -+ | 21x |
- #' control_lineplot_vars(group_var = NA)+ strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level) |
| 586 | -+ | 21x |
- #'+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights))) |
| 587 | -+ | 8x |
- #' @export+ if (diff_v[length(diff_v)] < tol) break |
| 588 | -+ | 13x |
- control_lineplot_vars <- function(x = "AVISIT",+ initial_weights <- weights_new |
| 589 |
- y = "AVAL",+ } |
||
| 590 |
- group_var = "ARM",+ |
||
| 591 | -+ | 9x |
- facet_var = NA,+ if (it == max_iterations) {
|
| 592 | -+ | 1x |
- paramcd = "PARAMCD",+ warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
|
| 593 |
- y_unit = "AVALU",+ } |
||
| 594 |
- subject_var = "USUBJID") {
+
|
||
| 595 | -16x | +9x |
- checkmate::assert_string(x)+ list( |
| 596 | -16x | +9x |
- checkmate::assert_string(y)+ "n_it" = it, |
| 597 | -16x | +9x |
- checkmate::assert_string(group_var, na.ok = TRUE, null.ok = TRUE)+ "weights" = weights_new, |
| 598 | -16x | -
- checkmate::assert_string(facet_var, na.ok = TRUE, null.ok = TRUE)- |
- |
| 599 | -16x | -
- checkmate::assert_string(subject_var, na.ok = TRUE, null.ok = TRUE)- |
- |
| 600 | -16x | -
- checkmate::assert_string(paramcd, na.ok = TRUE, null.ok = TRUE)- |
- |
| 601 | -16x | -
- checkmate::assert_string(y_unit, na.ok = TRUE, null.ok = TRUE)- |
- |
| 602 | -- | - - | -|
| 603 | -16x | -
- variables <- c(- |
- |
| 604 | -16x | -
- x = x, y = y, group_var = group_var, paramcd = paramcd,- |
- |
| 605 | -16x | +9x |
- y_unit = y_unit, subject_var = subject_var, facet_var = facet_var+ "diff_v" = diff_v |
| 606 | +599 |
) |
|
| 607 | -16x | -
- return(variables)- |
- |
| 608 | +600 |
}@@ -48336,14 +47274,14 @@ tern coverage - 95.65% |
| 1 |
- #' Count the number of patients with particular flags+ #' Helper function for deriving analysis datasets for select laboratory tables |
||
| 5 |
- #' The analyze function [count_patients_with_flags()] creates a layout element to calculate counts of patients for+ #' Helper function that merges ADSL and ADLB datasets so that missing lab test records are inserted in the |
||
| 6 |
- #' which user-specified flags are present.+ #' output dataset. Remember that `na_level` must match the needed pre-processing |
||
| 7 |
- #'+ #' done with [df_explicit_na()] to have the desired output. |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates unique subject identifiers. Flags+ #' |
||
| 9 |
- #' variables to analyze are specified by the user via the `flag_variables` argument, and must either take value+ #' @param adsl (`data.frame`)\cr ADSL data frame. |
||
| 10 |
- #' `TRUE` (flag present) or `FALSE` (flag absent) for each record.+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 11 |
- #'+ #' @param worst_flag (named `character`)\cr worst post-baseline lab flag variable. See how this is implemented in the |
||
| 12 |
- #' If there are multiple records with the same flag present for a patient, only one occurrence is counted.+ #' following examples. |
||
| 13 |
- #'+ #' @param by_visit (`flag`)\cr defaults to `FALSE` to generate worst grade per patient. |
||
| 14 |
- #' @inheritParams argument_convention+ #' If worst grade per patient per visit is specified for `worst_flag`, then |
||
| 15 |
- #' @param flag_variables (`character`)\cr a vector specifying the names of `logical` variables from analysis dataset+ #' `by_visit` should be `TRUE` to generate worst grade patient per visit. |
||
| 16 |
- #' used for counting the number of unique identifiers.+ #' @param no_fillin_visits (named `character`)\cr visits that are not considered for post-baseline worst toxicity |
||
| 17 |
- #' @param flag_labels (`character`)\cr vector of labels to use for flag variables. If any labels are also specified via+ #' grade. Defaults to `c("SCREENING", "BASELINE")`.
|
||
| 18 |
- #' the `.labels` parameter, the `.labels` values will take precedence and replace these labels.+ #' |
||
| 19 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`, |
||
| 20 |
- #'+ #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when |
||
| 21 |
- #' Options are: ``r shQuote(get_stats("count_patients_with_flags"))``
+ #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
|
||
| 23 |
- #' @seealso [count_patients_with_event]+ #' @details In the result data missing records will be created for the following situations: |
||
| 24 |
- #'+ #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline). |
||
| 25 |
- #' @name count_patients_with_flags+ #' * Patients who do not have any post-baseline lab values. |
||
| 26 |
- #' @order 1+ #' * Patients without any post-baseline values flagged as the worst. |
||
| 27 |
- NULL+ #' |
||
| 28 |
-
+ #' @examples |
||
| 29 |
- #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which+ #' # `h_adsl_adlb_merge_using_worst_flag` |
||
| 30 |
- #' a particular flag variable is `TRUE`.+ #' adlb_out <- h_adsl_adlb_merge_using_worst_flag( |
||
| 31 |
- #'+ #' tern_ex_adsl, |
||
| 32 |
- #' @inheritParams analyze_variables+ #' tern_ex_adlb, |
||
| 33 |
- #' @param .var (`string`)\cr name of the column that contains the unique identifier.+ #' worst_flag = c("WGRHIFL" = "Y")
|
||
| 34 |
- #'+ #' ) |
||
| 35 |
- #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not+ #' |
||
| 36 |
- #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to+ #' # `h_adsl_adlb_merge_using_worst_flag` by visit example |
||
| 37 |
- #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is+ #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag( |
||
| 38 |
- #' the label to use for this variable.+ #' tern_ex_adsl, |
||
| 39 |
- #'+ #' tern_ex_adlb, |
||
| 40 |
- #' @return+ #' worst_flag = c("WGRLOVFL" = "Y"),
|
||
| 41 |
- #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular+ #' by_visit = TRUE |
||
| 42 |
- #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag.+ #' ) |
||
| 44 |
- #' @examples+ #' @export |
||
| 45 |
- #' # `s_count_patients_with_flags()`+ h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint |
||
| 46 |
- #'+ adlb, |
||
| 47 |
- #' s_count_patients_with_flags(+ worst_flag = c("WGRHIFL" = "Y"),
|
||
| 48 |
- #' adae,+ by_visit = FALSE, |
||
| 49 |
- #' "SUBJID",+ no_fillin_visits = c("SCREENING", "BASELINE")) {
|
||
| 50 | -+ | 5x |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ col_names <- names(worst_flag) |
| 51 | -+ | 5x |
- #' denom = "N_col",+ filter_values <- worst_flag |
| 52 |
- #' .N_col = 1000+ |
||
| 53 | -+ | 5x |
- #' )+ temp <- Map( |
| 54 | -+ | 5x |
- #'+ function(x, y) which(adlb[[x]] == y), |
| 55 | -+ | 5x |
- #' @export+ col_names, |
| 56 | -+ | 5x |
- s_count_patients_with_flags <- function(df,+ filter_values |
| 57 |
- .var,+ ) |
||
| 58 |
- flag_variables,+ |
||
| 59 | -+ | 5x |
- flag_labels = NULL,+ position_satisfy_filters <- Reduce(intersect, temp) |
| 60 |
- .N_col, # nolint+ |
||
| 61 | -+ | 5x |
- .N_row, # nolint+ adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb)) |
| 62 | -+ | 5x |
- denom = c("n", "N_col", "N_row")) {
+ columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
|
| 63 | -39x | +
- checkmate::assert_character(flag_variables)+ |
|
| 64 | -39x | +5x |
- if (!is.null(flag_labels)) {
+ adlb_f <- adlb[position_satisfy_filters, ] %>% |
| 65 | -6x | +5x |
- checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE)+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) |
| 66 | -6x | +5x |
- flag_names <- flag_labels+ adlb_f <- adlb_f[, columns_from_adlb] |
| 67 |
- } else {
+
|
||
| 68 | -33x | +5x |
- if (is.null(names(flag_variables))) {
+ avisits_grid <- adlb %>% |
| 69 | -20x | +5x |
- flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE)+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>% |
| 70 | -+ | 5x |
- } else {
+ dplyr::pull(.data[["AVISIT"]]) %>% |
| 71 | -13x | +5x |
- flag_names <- unname(flag_variables)+ unique() |
| 72 | -13x | +
- flag_variables <- names(flag_variables)+ |
|
| 73 | -+ | 5x |
- }+ if (by_visit) {
|
| 74 | -+ | 1x |
- }+ adsl_lb <- expand.grid( |
| 75 | -+ | 1x |
-
+ USUBJID = unique(adsl$USUBJID), |
| 76 | -39x | +1x |
- checkmate::assert_subset(flag_variables, colnames(df))+ AVISIT = avisits_grid, |
| 77 | -39x | +1x |
- temp <- sapply(flag_variables, function(x) {
+ PARAMCD = unique(adlb$PARAMCD) |
| 78 | -119x | +
- tmp <- Map(function(y) which(df[[y]]), x)+ ) |
|
| 79 | -119x | +
- position_satisfy_flags <- Reduce(intersect, tmp)+ |
|
| 80 | -119x | +1x |
- id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))+ adsl_lb <- adsl_lb %>% |
| 81 | -119x | +1x |
- s_count_values(+ dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
|
| 82 | -119x | +1x |
- as.character(unique(df[[.var]])),+ dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
| 83 | -119x | +
- id_satisfy_flags,+ |
|
| 84 | -119x | +1x |
- denom = denom,+ adsl1 <- adsl[, adsl_adlb_common_columns] |
| 85 | -119x | +1x |
- .N_col = .N_col,+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
| 86 | -119x | +
- .N_row = .N_row+ |
|
| 87 | -+ | 1x |
- )+ by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
|
| 88 |
- })+ |
||
| 89 | -39x | +1x |
- colnames(temp) <- flag_names+ adlb_btoxgr <- adlb %>% |
| 90 | -39x | +1x |
- temp <- data.frame(t(temp))+ dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
|
| 91 | -39x | +1x |
- result <- temp %>% as.list()+ unique() %>% |
| 92 | -39x | +1x |
- if (length(flag_variables) == 1) {
+ dplyr::rename("BTOXGR_MAP" = "BTOXGR")
|
| 93 | -1x | +
- for (i in 1:3) names(result[[i]]) <- flag_names[1]+ |
|
| 94 | -+ | 1x |
- }+ adlb_out <- merge( |
| 95 | -39x | +1x |
- result+ adlb_f, |
| 96 | -+ | 1x |
- }+ adsl_lb, |
| 97 | -+ | 1x |
-
+ by = by_variables_from_adlb, |
| 98 | -+ | 1x |
- #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun`+ all = TRUE, |
| 99 | -+ | 1x |
- #' in `count_patients_with_flags()`.+ sort = FALSE |
| 100 |
- #'+ ) |
||
| 101 | -+ | 1x |
- #' @return+ adlb_out <- adlb_out %>% |
| 102 | -+ | 1x |
- #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()].+ dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
|
| 103 | -+ | 1x |
- #'+ dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>% |
| 104 | -+ | 1x |
- #' @examples+ dplyr::select(-"BTOXGR_MAP") |
| 105 |
- #' a_count_patients_with_flags(+ |
||
| 106 | -+ | 1x |
- #' adae,+ adlb_var_labels <- c( |
| 107 | -+ | 1x |
- #' .N_col = 10L,+ formatters::var_labels(adlb[by_variables_from_adlb]), |
| 108 | -+ | 1x |
- #' .N_row = 10L,+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]), |
| 109 | -+ | 1x |
- #' .var = "USUBJID",+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
| 110 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
+ ) |
||
| 111 |
- #' )+ } else {
|
||
| 112 | -+ | 4x |
- #'+ adsl_lb <- expand.grid( |
| 113 | -+ | 4x |
- #' @export+ USUBJID = unique(adsl$USUBJID), |
| 114 | -+ | 4x |
- a_count_patients_with_flags <- function(df,+ PARAMCD = unique(adlb$PARAMCD) |
| 115 |
- labelstr = "",+ ) |
||
| 116 |
- flag_variables,+ |
||
| 117 | -+ | 4x |
- flag_labels = NULL,+ adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
| 118 |
- denom = c("n", "N_col", "N_row"),
+
|
||
| 119 | -+ | 4x |
- .N_col, # nolint+ adsl1 <- adsl[, adsl_adlb_common_columns] |
| 120 | -+ | 4x |
- .N_row, # nolint+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
| 121 |
- .df_row,+ |
||
| 122 | -+ | 4x |
- .var = NULL,+ by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
|
| 123 |
- .stats = NULL,+ |
||
| 124 | -+ | 4x |
- .formats = NULL,+ adlb_out <- merge( |
| 125 | -+ | 4x |
- .labels = NULL,+ adlb_f, |
| 126 | -+ | 4x |
- .indent_mods = NULL,+ adsl_lb, |
| 127 | -+ | 4x |
- na_str = default_na_str()) {
+ by = by_variables_from_adlb, |
| 128 | -29x | +4x |
- x_stats <- s_count_patients_with_flags(+ all = TRUE, |
| 129 | -29x | +4x |
- df = df, .var = .var, flag_variables = flag_variables, flag_labels = flag_labels,+ sort = FALSE |
| 130 | -29x | +
- .N_col = .N_col, .N_row = .N_row, denom = denom+ ) |
|
| 131 |
- )+ |
||
| 132 | -+ | 4x |
-
+ adlb_var_labels <- c( |
| 133 | -29x | +4x |
- if (is.null(unlist(x_stats))) {
+ formatters::var_labels(adlb[by_variables_from_adlb]), |
| 134 | -! | +4x |
- return(NULL)+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]), |
| 135 | -+ | 4x |
- }+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
| 136 | -29x | +
- x_lvls <- names(x_stats[[1]])+ ) |
|
| 137 |
-
+ } |
||
| 138 |
- # Fill in with formatting defaults if needed+ |
||
| 139 | -29x | +5x |
- .stats <- get_stats("count_patients_with_flags", stats_in = .stats)
+ adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR) |
| 140 | -29x | +5x |
- .formats <- get_formats_from_stats(.stats, .formats)+ adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR) |
| 142 | -+ | 5x |
- # label formatting+ formatters::var_labels(adlb_out) <- adlb_var_labels |
| 143 | -29x | +
- x_nms <- paste(rep(.stats, each = length(flag_variables)), flag_variables, sep = ".")+ |
|
| 144 | -29x | +5x |
- new_lbls <- if (!is.null(.labels)) .labels[names(.labels) %in% x_nms] else NULL+ adlb_out |
| 145 | -29x | -
- .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls) %>% setNames(x_nms)- |
- |
| 146 | -29x | -
- if (!is.null(new_lbls)) {
- |
- |
| 147 | -1x | -
- which_lbls <- which(names(new_lbls) %in% names(.labels))- |
- |
| 148 | -1x | +
- .labels[which_lbls] <- new_lbls+ } |
| 149 | +1 |
- }+ #' Control function for Cox regression |
||
| 150 | +2 |
-
+ #' |
||
| 151 | +3 |
- # indent mod formatting+ #' @description `r lifecycle::badge("stable")`
|
||
| 152 | -29x | +|||
| 4 | +
- indent_stat_def <- if (any(.stats %in% names(.indent_mods))) {
+ #' |
|||
| 153 | -1x | +|||
| 5 | +
- .indent_mods[.stats[.stats %in% names(.indent_mods)]]+ #' Sets a list of parameters for Cox regression fit. Used internally. |
|||
| 154 | +6 |
- } else {
+ #' |
||
| 155 | -28x | +|||
| 7 | +
- NULL+ #' @inheritParams argument_convention |
|||
| 156 | +8 |
- }+ #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
||
| 157 | -29x | +|||
| 9 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = flag_variables)+ #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied |
|||
| 158 | -29x | +|||
| 10 | +
- .indent_mods <- sapply(names(.indent_mods), function(x) {
+ #' treatment and candidate covariate. Note that for univariate models without treatment arm, and |
|||
| 159 | -114x | +|||
| 11 | +
- if (.indent_mods[x] == 0 && !is.null(length(indent_stat_def))) {
+ #' multivariate models, no interaction can be used so that this needs to be `FALSE`. |
|||
| 160 | -112x | +|||
| 12 | +
- idx <- which(names(indent_stat_def) == gsub("\\..*", "", x))
+ #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`, |
|||
| 161 | -2x | +|||
| 13 | +
- if (length(idx) > 0) .indent_mods[[x]] <- indent_stat_def[[idx]]+ #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R. |
|||
| 162 | +14 |
- }+ #' |
||
| 163 | -114x | +|||
| 15 | +
- .indent_mods[x]+ #' @return A `list` of items with names corresponding to the arguments. |
|||
| 164 | +16 |
- })+ #' |
||
| 165 | +17 |
-
+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
||
| 166 | -1x | +|||
| 18 | +
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ #' |
|||
| 167 | -29x | +|||
| 19 | +
- x_stats <- x_stats[.stats]+ #' @examples |
|||
| 168 | +20 |
-
+ #' control_coxreg() |
||
| 169 | +21 |
- # Ungroup statistics with values for each level of x+ #' |
||
| 170 | -29x | +|||
| 22 | +
- x_ungrp <- ungroup_stats(x_stats, .formats, .labels, list())+ #' @export |
|||
| 171 | -29x | +|||
| 23 | +
- x_stats <- x_ungrp[["x"]] %>% setNames(x_nms)+ control_coxreg <- function(pval_method = c("wald", "likelihood"),
|
|||
| 172 | -29x | +|||
| 24 | +
- .formats <- x_ungrp[[".formats"]] %>% setNames(x_nms)+ ties = c("exact", "efron", "breslow"),
|
|||
| 173 | +25 |
-
+ conf_level = 0.95, |
||
| 174 | +26 |
- # Auto format handling+ interaction = FALSE) {
|
||
| 175 | -29x | +27 | +55x |
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ pval_method <- match.arg(pval_method) |
| 176 | -+ | |||
| 28 | +55x |
-
+ ties <- match.arg(ties) |
||
| 177 | -29x | +29 | +55x |
- in_rows(+ checkmate::assert_flag(interaction) |
| 178 | -29x | +30 | +55x |
- .list = x_stats,+ assert_proportion_value(conf_level) |
| 179 | -29x | +31 | +55x |
- .formats = .formats,+ list( |
| 180 | -29x | +32 | +55x |
- .names = names(.labels),+ pval_method = pval_method, |
| 181 | -29x | +33 | +55x |
- .labels = unlist(.labels),+ ties = ties, |
| 182 | -29x | +34 | +55x |
- .indent_mods = .indent_mods,+ conf_level = conf_level, |
| 183 | -29x | +35 | +55x |
- .format_na_strs = na_str+ interaction = interaction |
| 184 | +36 |
) |
||
| 185 | +37 |
} |
||
| 186 | +38 | |||
| 187 | +39 |
- #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function+ #' Custom tidy methods for Cox regression |
||
| 188 | +40 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 189 | +41 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 190 | +42 |
- #' @return+ #' |
||
| 191 | +43 |
- #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions,+ #' @inheritParams argument_convention |
||
| 192 | +44 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @param x (`list`)\cr result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models) |
||
| 193 | +45 |
- #' the statistics from `s_count_patients_with_flags()` to the table layout.+ #' or [fit_coxreg_multivar()] (for multivariate models). |
||
| 194 | +46 |
#' |
||
| 195 | +47 |
- #' @examples+ #' @return [broom::tidy()] returns: |
||
| 196 | +48 |
- #' # Add labelled flag variables to analysis dataset.+ #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`, |
||
| 197 | +49 |
- #' adae <- tern_ex_adae %>%+ #' `upper .95`, `level`, and `n`. |
||
| 198 | +50 |
- #' dplyr::mutate(+ #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`, |
||
| 199 | +51 |
- #' fl1 = TRUE %>% with_label("Total AEs"),
+ #' `lcl`, `ucl`, `pval`, and `ci`. |
||
| 200 | +52 |
- #' fl2 = (TRTEMFL == "Y") %>%+ #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`, |
||
| 201 | +53 |
- #' with_label("Total number of patients with at least one adverse event"),
+ #' `level`, and `ci`. |
||
| 202 | +54 |
- #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>%+ #' |
||
| 203 | +55 |
- #' with_label("Total number of patients with fatal AEs"),
+ #' @seealso [cox_regression] |
||
| 204 | +56 |
- #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>%+ #' |
||
| 205 | +57 |
- #' with_label("Total number of patients with related fatal AEs")
+ #' @name tidy_coxreg |
||
| 206 | +58 |
- #' )+ NULL |
||
| 207 | +59 |
- #'+ |
||
| 208 | +60 |
- #' lyt <- basic_table() %>%+ #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results. |
||
| 209 | +61 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 210 | +62 |
- #' add_colcounts() %>%+ #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results. |
||
| 211 | +63 |
- #' count_patients_with_flags(+ #' |
||
| 212 | +64 |
- #' "SUBJID",+ #' @method tidy summary.coxph |
||
| 213 | +65 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ #' |
||
| 214 | +66 |
- #' denom = "N_col"+ #' @examples |
||
| 215 | +67 |
- #' )+ #' library(survival) |
||
| 216 | +68 |
- #'+ #' library(broom) |
||
| 217 | +69 |
- #' build_table(lyt, adae, alt_counts_df = tern_ex_adsl)+ #' |
||
| 218 | +70 |
- #'+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 219 | +71 |
- #' @export+ #' |
||
| 220 | +72 |
- #' @order 2+ #' dta_bladder <- with( |
||
| 221 | +73 |
- count_patients_with_flags <- function(lyt,+ #' data = bladder[bladder$enum < 5, ], |
||
| 222 | +74 |
- var,+ #' data.frame( |
||
| 223 | +75 |
- flag_variables,+ #' time = stop, |
||
| 224 | +76 |
- flag_labels = NULL,+ #' status = event, |
||
| 225 | +77 |
- var_labels = var,+ #' armcd = as.factor(rx), |
||
| 226 | +78 |
- show_labels = "hidden",+ #' covar1 = as.factor(enum), |
||
| 227 | +79 |
- riskdiff = FALSE,+ #' covar2 = factor( |
||
| 228 | +80 |
- na_str = default_na_str(),+ #' sample(as.factor(enum)), |
||
| 229 | +81 |
- nested = TRUE,+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 230 | +82 |
- ...,+ #' ) |
||
| 231 | +83 |
- table_names = paste0("tbl_flags_", var),
+ #' ) |
||
| 232 | +84 |
- .stats = "count_fraction",+ #' ) |
||
| 233 | +85 |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 234 | +86 |
- .indent_mods = NULL,+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 235 | +87 |
- .labels = NULL) {
- |
- ||
| 236 | -10x | -
- checkmate::assert_flag(riskdiff)- |
- ||
| 237 | -10x | -
- extra_args <- list(+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 238 | -10x | +|||
| 88 | +
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ #' |
|||
| 239 | +89 |
- )+ #' formula <- "survival::Surv(time, status) ~ armcd + covar1" |
||
| 240 | -10x | +|||
| 90 | +
- s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...)+ #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder)) |
|||
| 241 | +91 |
-
+ #' tidy(msum) |
||
| 242 | -10x | +|||
| 92 | +
- if (isFALSE(riskdiff)) {
+ #' |
|||
| 243 | -8x | +|||
| 93 | +
- extra_args <- c(extra_args, s_args)+ #' @export |
|||
| 244 | +94 |
- } else {
+ tidy.summary.coxph <- function(x, # nolint |
||
| 245 | -2x | +|||
| 95 | +
- extra_args <- c(+ ...) {
|
|||
| 246 | -2x | +96 | +199x |
- extra_args,+ checkmate::assert_class(x, "summary.coxph") |
| 247 | -2x | +97 | +199x |
- list(+ pval <- x$coefficients |
| 248 | -2x | +98 | +199x |
- afun = list("s_count_patients_with_flags" = a_count_patients_with_flags),
+ confint <- x$conf.int |
| 249 | -2x | -
- s_args = s_args- |
- ||
| 250 | -- |
- )- |
- ||
| 251 | -- |
- )- |
- ||
| 252 | -+ | 99 | +199x |
- }+ levels <- rownames(pval) |
| 253 | +100 | |||
| 254 | -10x | -
- analyze(- |
- ||
| 255 | -10x | +101 | +199x |
- lyt = lyt,+ pval <- tibble::as_tibble(pval) |
| 256 | -10x | +102 | +199x |
- vars = var,+ confint <- tibble::as_tibble(confint) |
| 257 | -10x | +|||
| 103 | +
- afun = ifelse(isFALSE(riskdiff), a_count_patients_with_flags, afun_riskdiff),+ |
|||
| 258 | -10x | +104 | +199x |
- var_labels = var_labels,+ ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
|
| 259 | -10x | +105 | +199x |
- show_labels = show_labels,+ ret$level <- levels |
| 260 | -10x | +106 | +199x |
- table_names = table_names,+ ret$n <- x[["n"]] |
| 261 | -10x | +107 | +199x |
- na_str = na_str,+ ret |
| 262 | -10x | +|||
| 108 | +
- nested = nested,+ } |
|||
| 263 | -10x | +|||
| 109 | +
- extra_args = extra_args+ |
|||
| 264 | +110 |
- )+ #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression. |
||
| 265 | +111 |
- }+ #' |
| 1 | +112 |
- #' Survival time analysis+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()]. |
||
| 2 | +113 |
#' |
||
| 3 | +114 |
- #' @description `r lifecycle::badge("stable")`
+ #' @method tidy coxreg.univar |
||
| 4 | +115 |
#' |
||
| 5 | +116 |
- #' The analyze function [surv_time()] creates a layout element to analyze survival time by calculating survival time+ #' @examples |
||
| 6 | +117 |
- #' median, median confidence interval, quantiles, and range (for all, censored, or event patients). The primary+ #' ## Cox regression: arm + 1 covariate. |
||
| 7 | +118 |
- #' analysis variable `vars` is the time variable and the secondary analysis variable `is_event` indicates whether or+ #' mod1 <- fit_coxreg_univar( |
||
| 8 | +119 |
- #' not an event has occurred.+ #' variables = list( |
||
| 9 | +120 |
- #'+ #' time = "time", event = "status", arm = "armcd", |
||
| 10 | +121 |
- #' @inheritParams argument_convention+ #' covariates = "covar1" |
||
| 11 | +122 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' ), |
||
| 12 | +123 |
- #' [control_surv_time()]. Some possible parameter options are:+ #' data = dta_bladder, |
||
| 13 | +124 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.+ #' control = control_coxreg(conf_level = 0.91) |
||
| 14 | +125 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log",+ #' ) |
||
| 15 | +126 |
- #' see more in [survival::survfit()]. Note option "none" is not supported.+ #' |
||
| 16 | +127 |
- #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
||
| 17 | +128 |
- #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed+ #' mod2 <- fit_coxreg_univar( |
||
| 18 | +129 |
- #' when the `range` statistic is included.+ #' variables = list( |
||
| 19 | +130 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' time = "time", event = "status", arm = "armcd", |
||
| 20 | +131 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' covariates = c("covar1", "covar2")
|
||
| 21 | +132 |
- #' for that statistic's row label.+ #' ), |
||
| 22 | +133 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' data = dta_bladder, |
||
| 23 | +134 |
- #'+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
||
| 24 | +135 |
- #' Options are: ``r shQuote(get_stats("surv_time"))``
+ #' ) |
||
| 25 | +136 |
#' |
||
| 26 | +137 |
- #' @examples+ #' tidy(mod1) |
||
| 27 | +138 |
- #' library(dplyr)+ #' tidy(mod2) |
||
| 28 | +139 |
#' |
||
| 29 | -- |
- #' adtte_f <- tern_ex_adtte %>%- |
- ||
| 30 | -- |
- #' filter(PARAMCD == "OS") %>%- |
- ||
| 31 | -- |
- #' mutate(- |
- ||
| 32 | -- |
- #' AVAL = day2month(AVAL),- |
- ||
| 33 | +140 |
- #' is_event = CNSR == 0+ #' @export |
||
| 34 | +141 |
- #' )+ tidy.coxreg.univar <- function(x, # nolint |
||
| 35 | +142 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ ...) {
|
||
| 36 | -+ | |||
| 143 | +38x |
- #'+ checkmate::assert_class(x, "coxreg.univar") |
||
| 37 | -+ | |||
| 144 | +38x |
- #' @name survival_time+ mod <- x$mod |
||
| 38 | -+ | |||
| 145 | +38x |
- #' @order 1+ vars <- c(x$vars$arm, x$vars$covariates) |
||
| 39 | -+ | |||
| 146 | +38x |
- NULL+ has_arm <- "arm" %in% names(x$vars) |
||
| 40 | +147 | |||
| 41 | -+ | |||
| 148 | +38x |
- #' @describeIn survival_time Statistics function which analyzes survival times.+ result <- if (!has_arm) {
|
||
| 42 | -+ | |||
| 149 | +5x |
- #'+ Map( |
||
| 43 | -+ | |||
| 150 | +5x |
- #' @return+ mod = mod, vars = vars, |
||
| 44 | -+ | |||
| 151 | +5x |
- #' * `s_surv_time()` returns the statistics:+ f = function(mod, vars) {
|
||
| 45 | -+ | |||
| 152 | +6x |
- #' * `median`: Median survival time.+ h_coxreg_multivar_extract( |
||
| 46 | -+ | |||
| 153 | +6x |
- #' * `median_ci`: Confidence interval for median time.+ var = vars, |
||
| 47 | -+ | |||
| 154 | +6x |
- #' * `quantiles`: Survival time for two specified quantiles.+ data = x$data, |
||
| 48 | -+ | |||
| 155 | +6x |
- #' * `range_censor`: Survival time range for censored observations.+ mod = mod, |
||
| 49 | -+ | |||
| 156 | +6x |
- #' * `range_event`: Survival time range for observations with events.+ control = x$control |
||
| 50 | +157 |
- #' * `range`: Survival time range for all observations.+ ) |
||
| 51 | +158 |
- #'+ } |
||
| 52 | +159 |
- #' @keywords internal+ ) |
||
| 53 | -+ | |||
| 160 | +38x |
- s_surv_time <- function(df,+ } else if (x$control$interaction) {
|
||
| 54 | -+ | |||
| 161 | +12x |
- .var,+ Map( |
||
| 55 | -+ | |||
| 162 | +12x |
- is_event,+ mod = mod, covar = vars, |
||
| 56 | -+ | |||
| 163 | +12x |
- control = control_surv_time()) {
+ f = function(mod, covar) {
|
||
| 57 | -232x | +164 | +26x |
- checkmate::assert_string(.var)+ h_coxreg_extract_interaction( |
| 58 | -232x | +165 | +26x |
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ effect = x$vars$arm, covar = covar, mod = mod, data = x$data, |
| 59 | -232x | +166 | +26x |
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ at = x$at, control = x$control |
| 60 | -232x | +|||
| 167 | +
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ ) |
|||
| 61 | +168 |
-
+ } |
||
| 62 | -232x | +|||
| 169 | +
- conf_type <- control$conf_type+ ) |
|||
| 63 | -232x | +|||
| 170 | +
- conf_level <- control$conf_level+ } else {
|
|||
| 64 | -232x | +171 | +21x |
- quantiles <- control$quantiles+ Map( |
| 65 | -+ | |||
| 172 | +21x |
-
+ mod = mod, vars = vars, |
||
| 66 | -232x | +173 | +21x |
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ f = function(mod, vars) {
|
| 67 | -232x | +174 | +53x |
- srv_fit <- survival::survfit(+ h_coxreg_univar_extract( |
| 68 | -232x | +175 | +53x |
- formula = formula,+ effect = x$vars$arm, covar = vars, data = x$data, mod = mod, |
| 69 | -232x | +176 | +53x |
- data = df,+ control = x$control |
| 70 | -232x | +|||
| 177 | +
- conf.int = conf_level,+ ) |
|||
| 71 | -232x | +|||
| 178 | +
- conf.type = conf_type+ } |
|||
| 72 | +179 |
- )+ ) |
||
| 73 | -232x | +|||
| 180 | +
- srv_tab <- summary(srv_fit, extend = TRUE)$table+ } |
|||
| 74 | -232x | +181 | +38x |
- srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile+ result <- do.call(rbind, result) |
| 75 | -232x | +|||
| 182 | +
- range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)+ |
|||
| 76 | -232x | +183 | +38x |
- range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
| 77 | -232x | +184 | +38x |
- range <- range_noinf(df[[.var]], na.rm = TRUE)+ result$n <- lapply(result$n, empty_vector_if_na) |
| 78 | -232x | +185 | +38x |
- list(+ result$ci <- lapply(result$ci, empty_vector_if_na) |
| 79 | -232x | +186 | +38x |
- median = formatters::with_label(unname(srv_tab["median"]), "Median"),+ result$hr <- lapply(result$hr, empty_vector_if_na) |
| 80 | -232x | +187 | +38x |
- median_ci = formatters::with_label(+ if (x$control$interaction) {
|
| 81 | -232x | +188 | +12x |
- unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
+ result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na) |
| 82 | +189 |
- ),- |
- ||
| 83 | -232x | -
- quantiles = formatters::with_label(+ # Remove interaction p-values due to change in specifications. |
||
| 84 | -232x | +190 | +12x |
- unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")+ result$pval[result$effect != "Treatment:"] <- NA |
| 85 | +191 |
- ),+ } |
||
| 86 | -232x | +192 | +38x |
- range_censor = formatters::with_label(range_censor, "Range (censored)"),+ result$pval <- lapply(result$pval, empty_vector_if_na) |
| 87 | -232x | +193 | +38x |
- range_event = formatters::with_label(range_event, "Range (event)"),+ attr(result, "conf_level") <- x$control$conf_level |
| 88 | -232x | -
- range = formatters::with_label(range, "Range")- |
- ||
| 89 | -+ | 194 | +38x |
- )+ result |
| 90 | +195 |
} |
||
| 91 | +196 | |||
| 92 | +197 |
- #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`.+ #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression. |
||
| 93 | +198 |
#' |
||
| 94 | -- |
- #' @return- |
- ||
| 95 | +199 |
- #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()].+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()]. |
||
| 96 | +200 |
#' |
||
| 97 | +201 |
- #' @examples+ #' @method tidy coxreg.multivar |
||
| 98 | +202 |
- #' a_surv_time(+ #' |
||
| 99 | +203 |
- #' df,+ #' @examples |
||
| 100 | +204 |
- #' .df_row = df,+ #' multivar_model <- fit_coxreg_multivar( |
||
| 101 | +205 |
- #' .var = "AVAL",+ #' variables = list( |
||
| 102 | +206 |
- #' is_event = "is_event"+ #' time = "time", event = "status", arm = "armcd", |
||
| 103 | +207 |
- #' )+ #' covariates = c("covar1", "covar2")
|
||
| 104 | +208 |
- #'+ #' ), |
||
| 105 | +209 |
- #' @export+ #' data = dta_bladder |
||
| 106 | +210 |
- a_surv_time <- function(df,+ #' ) |
||
| 107 | +211 |
- labelstr = "",+ #' broom::tidy(multivar_model) |
||
| 108 | +212 |
- .var = NULL,+ #' |
||
| 109 | +213 |
- .df_row = NULL,+ #' @export |
||
| 110 | +214 |
- is_event,+ tidy.coxreg.multivar <- function(x, # nolint |
||
| 111 | +215 |
- control = control_surv_time(),+ ...) {
|
||
| 112 | -+ | |||
| 216 | +16x |
- ref_fn_censor = TRUE,+ checkmate::assert_class(x, "coxreg.multivar") |
||
| 113 | -+ | |||
| 217 | +16x |
- .stats = NULL,+ vars <- c(x$vars$arm, x$vars$covariates) |
||
| 114 | +218 |
- .formats = NULL,+ |
||
| 115 | +219 |
- .labels = NULL,+ # Convert the model summaries to data. |
||
| 116 | -+ | |||
| 220 | +16x |
- .indent_mods = NULL,+ result <- Map( |
||
| 117 | -+ | |||
| 221 | +16x |
- na_str = default_na_str()) {
+ vars = vars, |
||
| 118 | -14x | +222 | +16x |
- x_stats <- s_surv_time(+ f = function(vars) {
|
| 119 | -14x | +223 | +60x |
- df = df, .var = .var, is_event = is_event, control = control+ h_coxreg_multivar_extract( |
| 120 | -+ | |||
| 224 | +60x |
- )+ var = vars, data = x$data, |
||
| 121 | -14x | +225 | +60x |
- rng_censor_lwr <- x_stats[["range_censor"]][1]+ mod = x$mod, control = x$control |
| 122 | -14x | +|||
| 226 | +
- rng_censor_upr <- x_stats[["range_censor"]][2]+ ) |
|||
| 123 | +227 |
-
+ } |
||
| 124 | +228 |
- # Use method-specific defaults+ ) |
||
| 125 | -14x | +229 | +16x |
- fmts <- c(median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x")+ result <- do.call(rbind, result) |
| 126 | -14x | +|||
| 230 | +
- lbls <- c(median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)")+ |
|||
| 127 | -14x | +231 | +16x |
- lbls_custom <- .labels+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
| 128 | -14x | +232 | +16x |
- .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))])+ result$ci <- lapply(result$ci, empty_vector_if_na) |
| 129 | -14x | +233 | +16x |
- .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))])+ result$hr <- lapply(result$hr, empty_vector_if_na) |
| 130 | -+ | |||
| 234 | +16x |
-
+ result$pval <- lapply(result$pval, empty_vector_if_na) |
||
| 131 | -+ | |||
| 235 | +16x |
- # Fill in with formatting defaults if needed+ result <- result[, names(result) != "n"] |
||
| 132 | -14x | +236 | +16x |
- .stats <- get_stats("surv_time", stats_in = .stats)
+ attr(result, "conf_level") <- x$control$conf_level |
| 133 | -14x | +|||
| 237 | +
- .formats <- get_formats_from_stats(.stats, .formats)+ |
|||
| 134 | -14x | +238 | +16x |
- .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom)+ result |
| 135 | -14x | +|||
| 239 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ } |
|||
| 136 | +240 | |||
| 137 | -14x | +|||
| 241 | +
- x_stats <- x_stats[.stats]+ #' Fitting functions for Cox proportional hazards regression |
|||
| 138 | +242 |
-
+ #' |
||
| 139 | +243 |
- # Auto format handling+ #' @description `r lifecycle::badge("stable")`
|
||
| 140 | -14x | +|||
| 244 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' |
|||
| 141 | +245 |
-
+ #' Fitting functions for univariate and multivariate Cox regression models. |
||
| 142 | -14x | +|||
| 246 | +
- cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
+ #' |
|||
| 143 | -14x | +|||
| 247 | +
- if ("range" %in% names(x_stats) && ref_fn_censor) {
+ #' @param variables (named `list`)\cr the names of the variables found in `data`, passed as a named list and |
|||
| 144 | -14x | +|||
| 248 | +
- if (identical(x_stats[["range"]][1], rng_censor_lwr) && identical(x_stats[["range"]][2], rng_censor_upr)) {
+ #' corresponding to the `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from |
|||
| 145 | -2x | +|||
| 249 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum"+ #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect |
|||
| 146 | -12x | +|||
| 250 | +
- } else if (identical(x_stats[["range"]][1], rng_censor_lwr)) {
+ #' estimates will be tabulated later. |
|||
| 147 | -2x | +|||
| 251 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum"+ #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models. |
|||
| 148 | -10x | +|||
| 252 | +
- } else if (identical(x_stats[["range"]][2], rng_censor_upr)) {
+ #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify |
|||
| 149 | -1x | +|||
| 253 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum"+ #' the value of the covariate at which the effect should be estimated. |
|||
| 150 | +254 |
- }+ #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()]. |
||
| 151 | +255 |
- }+ #' |
||
| 152 | +256 |
-
+ #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression]. |
||
| 153 | -14x | +|||
| 257 | +
- in_rows(+ #' |
|||
| 154 | -14x | +|||
| 258 | +
- .list = x_stats,+ #' @examples |
|||
| 155 | -14x | +|||
| 259 | +
- .formats = .formats,+ #' library(survival) |
|||
| 156 | -14x | +|||
| 260 | +
- .names = .labels,+ #' |
|||
| 157 | -14x | +|||
| 261 | +
- .labels = .labels,+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 158 | -14x | +|||
| 262 | +
- .indent_mods = .indent_mods,+ #' |
|||
| 159 | -14x | +|||
| 263 | +
- .format_na_strs = na_str,+ #' # Testing dataset [survival::bladder]. |
|||
| 160 | -14x | +|||
| 264 | +
- .cell_footnotes = cell_fns+ #' dta_bladder <- with( |
|||
| 161 | +265 |
- )+ #' data = bladder[bladder$enum < 5, ], |
||
| 162 | +266 |
- }+ #' data.frame( |
||
| 163 | +267 |
-
+ #' time = stop, |
||
| 164 | +268 |
- #' @describeIn survival_time Layout-creating function which can take statistics function arguments+ #' status = event, |
||
| 165 | +269 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' armcd = as.factor(rx), |
||
| 166 | +270 |
- #'+ #' covar1 = as.factor(enum), |
||
| 167 | +271 |
- #' @return+ #' covar2 = factor( |
||
| 168 | +272 |
- #' * `surv_time()` returns a layout object suitable for passing to further layouting functions,+ #' sample(as.factor(enum)), |
||
| 169 | +273 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 170 | +274 |
- #' the statistics from `s_surv_time()` to the table layout.+ #' ) |
||
| 171 | +275 |
- #'+ #' ) |
||
| 172 | +276 |
- #' @examples+ #' ) |
||
| 173 | +277 |
- #' basic_table() %>%+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 174 | +278 |
- #' split_cols_by(var = "ARMCD") %>%+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 175 | +279 |
- #' add_colcounts() %>%+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 176 | +280 |
- #' surv_time(+ #' |
||
| 177 | +281 |
- #' vars = "AVAL",+ #' plot( |
||
| 178 | +282 |
- #' var_labels = "Survival Time (Months)",+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
||
| 179 | +283 |
- #' is_event = "is_event",+ #' lty = 2:4, |
||
| 180 | +284 |
- #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log")+ #' xlab = "Months", |
||
| 181 | +285 |
- #' ) %>%+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
||
| 182 | +286 |
- #' build_table(df = adtte_f)+ #' ) |
||
| 183 | +287 |
#' |
||
| 184 | +288 |
- #' @export+ #' @name fit_coxreg |
||
| 185 | +289 |
- #' @order 2+ NULL |
||
| 186 | +290 |
- surv_time <- function(lyt,+ |
||
| 187 | +291 |
- vars,+ #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs. |
||
| 188 | +292 |
- is_event,+ #' |
||
| 189 | +293 |
- control = control_surv_time(),+ #' @return |
||
| 190 | +294 |
- ref_fn_censor = TRUE,+ #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list` |
||
| 191 | +295 |
- na_str = default_na_str(),+ #' with 5 elements: |
||
| 192 | +296 |
- nested = TRUE,+ #' * `mod`: Cox regression models fitted by [survival::coxph()]. |
||
| 193 | +297 |
- ...,+ #' * `data`: The original data frame input. |
||
| 194 | +298 |
- var_labels = "Time to Event",+ #' * `control`: The original control input. |
||
| 195 | +299 |
- show_labels = "visible",+ #' * `vars`: The variables used in the model. |
||
| 196 | +300 |
- table_names = vars,+ #' * `at`: Value of the covariate at which the effect should be estimated. |
||
| 197 | +301 |
- .stats = c("median", "median_ci", "quantiles", "range"),
+ #' |
||
| 198 | +302 |
- .formats = NULL,+ #' @note When using `fit_coxreg_univar` there should be two study arms. |
||
| 199 | +303 |
- .labels = NULL,+ #' |
||
| 200 | +304 |
- .indent_mods = c(median_ci = 1L)) {
+ #' @examples |
||
| 201 | -3x | +|||
| 305 | +
- extra_args <- list(+ #' # fit_coxreg_univar |
|||
| 202 | -3x | +|||
| 306 | +
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str,+ #' |
|||
| 203 | -3x | +|||
| 307 | +
- is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ...+ #' ## Cox regression: arm + 1 covariate. |
|||
| 204 | +308 |
- )+ #' mod1 <- fit_coxreg_univar( |
||
| 205 | +309 |
-
+ #' variables = list( |
||
| 206 | -3x | -
- analyze(- |
- ||
| 207 | -3x | -
- lyt = lyt,- |
- ||
| 208 | -3x | -
- vars = vars,- |
- ||
| 209 | -3x | -
- afun = a_surv_time,- |
- ||
| 210 | -3x | -
- var_labels = var_labels,- |
- ||
| 211 | -3x | -
- show_labels = show_labels,- |
- ||
| 212 | -3x | -
- table_names = table_names,- |
- ||
| 213 | -3x | -
- na_str = na_str,- |
- ||
| 214 | -3x | -
- nested = nested,- |
- ||
| 215 | -3x | +|||
| 310 | +
- extra_args = extra_args+ #' time = "time", event = "status", arm = "armcd", |
|||
| 216 | +311 |
- )+ #' covariates = "covar1" |
||
| 217 | +312 |
- }+ #' ), |
| 1 | +313 |
- #' Difference test for two proportions+ #' data = dta_bladder, |
||
| 2 | +314 |
- #'+ #' control = control_coxreg(conf_level = 0.91) |
||
| 3 | +315 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 4 | +316 |
#' |
||
| 5 | +317 |
- #' The analyze function [test_proportion_diff()] creates a layout element to test the difference between two+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
||
| 6 | +318 |
- #' proportions. The primary analysis variable, `vars`, indicates whether a response has occurred for each record. See+ #' mod2 <- fit_coxreg_univar( |
||
| 7 | +319 |
- #' the `method` parameter for options of methods to use to calculate the p-value. Additionally, a stratification+ #' variables = list( |
||
| 8 | +320 |
- #' variable can be supplied via the `strata` element of the `variables` argument.+ #' time = "time", event = "status", arm = "armcd", |
||
| 9 | +321 |
- #'+ #' covariates = c("covar1", "covar2")
|
||
| 10 | +322 |
- #' @inheritParams argument_convention+ #' ), |
||
| 11 | +323 |
- #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used+ #' data = dta_bladder, |
||
| 12 | +324 |
- #' to calculate the p-value.+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
||
| 13 | +325 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' ) |
||
| 14 | +326 |
#' |
||
| 15 | +327 |
- #' Options are: ``r shQuote(get_stats("test_proportion_diff"))``
+ #' ## Cox regression: arm + 1 covariate, stratified analysis. |
||
| 16 | +328 |
- #'+ #' mod3 <- fit_coxreg_univar( |
||
| 17 | +329 |
- #' @seealso [h_prop_diff_test]+ #' variables = list( |
||
| 18 | +330 |
- #'+ #' time = "time", event = "status", arm = "armcd", strata = "covar2", |
||
| 19 | +331 |
- #' @name prop_diff_test+ #' covariates = c("covar1")
|
||
| 20 | +332 |
- #' @order 1+ #' ), |
||
| 21 | +333 |
- NULL+ #' data = dta_bladder, |
||
| 22 | +334 |
-
+ #' control = control_coxreg(conf_level = 0.91) |
||
| 23 | +335 |
- #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions.+ #' ) |
||
| 24 | +336 |
#' |
||
| 25 | +337 |
- #' @return+ #' ## Cox regression: no arm, only covariates. |
||
| 26 | +338 |
- #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`+ #' mod4 <- fit_coxreg_univar( |
||
| 27 | +339 |
- #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.+ #' variables = list( |
||
| 28 | +340 |
- #'+ #' time = "time", event = "status", |
||
| 29 | +341 |
- #' @keywords internal+ #' covariates = c("covar1", "covar2")
|
||
| 30 | +342 |
- s_test_proportion_diff <- function(df,+ #' ), |
||
| 31 | +343 |
- .var,+ #' data = dta_bladder |
||
| 32 | +344 |
- .ref_group,+ #' ) |
||
| 33 | +345 |
- .in_ref_col,+ #' |
||
| 34 | +346 |
- variables = list(strata = NULL),+ #' @export |
||
| 35 | +347 |
- method = c("chisq", "schouten", "fisher", "cmh")) {
- |
- ||
| 36 | -45x | -
- method <- match.arg(method)+ fit_coxreg_univar <- function(variables, |
||
| 37 | -45x | +|||
| 348 | +
- y <- list(pval = "")+ data, |
|||
| 38 | +349 |
-
+ at = list(), |
||
| 39 | -45x | +|||
| 350 | +
- if (!.in_ref_col) {
+ control = control_coxreg()) {
|
|||
| 40 | -45x | +351 | +43x |
- assert_df_with_variables(df, list(rsp = .var))+ checkmate::assert_list(variables, names = "named") |
| 41 | -45x | +352 | +43x |
- assert_df_with_variables(.ref_group, list(rsp = .var))+ has_arm <- "arm" %in% names(variables) |
| 42 | -45x | +353 | +43x |
- rsp <- factor(+ arm_name <- if (has_arm) "arm" else NULL |
| 43 | -45x | +|||
| 354 | +
- c(.ref_group[[.var]], df[[.var]]),+ |
|||
| 44 | -45x | +355 | +43x |
- levels = c("TRUE", "FALSE")
+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 45 | +356 |
- )+ |
||
| 46 | -45x | +357 | +43x |
- grp <- factor(+ assert_df_with_variables(data, variables) |
| 47 | -45x | +358 | +43x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ assert_list_of_variables(variables[c(arm_name, "event", "time")])+ |
+
| 359 | ++ | + | ||
| 48 | -45x | +360 | +43x |
- levels = c("ref", "Not-ref")
+ if (!is.null(variables$strata)) {
|
| 49 | -+ | |||
| 361 | +4x |
- )+ checkmate::assert_disjunct(control$pval_method, "likelihood") |
||
| 50 | +362 |
-
+ } |
||
| 51 | -45x | +363 | +42x |
- if (!is.null(variables$strata) || method == "cmh") {
+ if (has_arm) {
|
| 52 | -12x | +364 | +36x |
- strata <- variables$strata+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 53 | -12x | +|||
| 365 | +
- checkmate::assert_false(is.null(strata))+ } |
|||
| 54 | -12x | +366 | +41x |
- strata_vars <- stats::setNames(as.list(strata), strata)+ vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE) |
| 55 | -12x | +367 | +41x |
- assert_df_with_variables(df, strata_vars)+ for (i in vars) {
|
| 56 | -12x | +368 | +94x |
- assert_df_with_variables(.ref_group, strata_vars)+ if (is.factor(data[[i]])) {
|
| 57 | -12x | +369 | +82x |
- strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))+ attr(data[[i]], "levels") <- levels(droplevels(data[[i]])) |
| 58 | +370 |
} |
||
| 59 | +371 |
-
+ } |
||
| 60 | -45x | +372 | +41x |
- tbl <- switch(method,+ forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction) |
| 61 | -45x | +373 | +41x |
- cmh = table(grp, rsp, strata),+ mod <- lapply( |
| 62 | -45x | +374 | +41x |
- table(grp, rsp)+ forms, function(x) {
+ |
+
| 375 | +90x | +
+ survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties) |
||
| 63 | +376 |
- )+ } |
||
| 64 | +377 |
-
+ ) |
||
| 65 | -45x | +378 | +41x |
- y$pval <- switch(method,+ structure( |
| 66 | -45x | +379 | +41x |
- chisq = prop_chisq(tbl),+ list( |
| 67 | -45x | +380 | +41x |
- cmh = prop_cmh(tbl),+ mod = mod, |
| 68 | -45x | +381 | +41x |
- fisher = prop_fisher(tbl),+ data = data, |
| 69 | -45x | +382 | +41x |
- schouten = prop_schouten(tbl)+ control = control, |
| 70 | -+ | |||
| 383 | +41x |
- )+ vars = variables, |
||
| 71 | -+ | |||
| 384 | +41x |
- }+ at = at |
||
| 72 | +385 |
-
+ ), |
||
| 73 | -45x | +386 | +41x |
- y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))+ class = "coxreg.univar" |
| 74 | -45x | +|||
| 387 | +
- y+ ) |
|||
| 75 | +388 |
} |
||
| 76 | +389 | |||
| 77 | +390 |
- #' Description of the difference test between two proportions+ #' @describeIn fit_coxreg Fit a multivariate Cox regression model. |
||
| 78 | +391 |
#' |
||
| 79 | +392 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 80 | +393 |
- #'+ #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list |
||
| 81 | +394 |
- #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`.+ #' with 4 elements: |
||
| 82 | +395 |
- #'+ #' * `mod`: Cox regression model fitted by [survival::coxph()]. |
||
| 83 | +396 |
- #' @inheritParams s_test_proportion_diff+ #' * `data`: The original data frame input. |
||
| 84 | +397 |
- #'+ #' * `control`: The original control input. |
||
| 85 | +398 |
- #' @return A `string` describing the test from which the p-value is derived.+ #' * `vars`: The variables used in the model. |
||
| 86 | +399 |
#' |
||
| 87 | +400 |
- #' @export+ #' @examples |
||
| 88 | +401 |
- d_test_proportion_diff <- function(method) {
+ #' # fit_coxreg_multivar |
||
| 89 | -59x | +|||
| 402 | +
- checkmate::assert_string(method)+ #' |
|||
| 90 | -59x | +|||
| 403 | +
- meth_part <- switch(method,+ #' ## Cox regression: multivariate Cox regression. |
|||
| 91 | -59x | +|||
| 404 | +
- "schouten" = "Chi-Squared Test with Schouten Correction",+ #' multivar_model <- fit_coxreg_multivar( |
|||
| 92 | -59x | +|||
| 405 | +
- "chisq" = "Chi-Squared Test",+ #' variables = list( |
|||
| 93 | -59x | +|||
| 406 | +
- "cmh" = "Cochran-Mantel-Haenszel Test",+ #' time = "time", event = "status", arm = "armcd", |
|||
| 94 | -59x | +|||
| 407 | +
- "fisher" = "Fisher's Exact Test",+ #' covariates = c("covar1", "covar2")
|
|||
| 95 | -59x | +|||
| 408 | +
- stop(paste(method, "does not have a description"))+ #' ), |
|||
| 96 | +409 |
- )+ #' data = dta_bladder |
||
| 97 | -59x | +|||
| 410 | +
- paste0("p-value (", meth_part, ")")
+ #' ) |
|||
| 98 | +411 |
- }+ #' |
||
| 99 | +412 |
-
+ #' # Example without treatment arm. |
||
| 100 | +413 |
- #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`.+ #' multivar_covs_model <- fit_coxreg_multivar( |
||
| 101 | +414 |
- #'+ #' variables = list( |
||
| 102 | +415 |
- #' @return+ #' time = "time", event = "status", |
||
| 103 | +416 |
- #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' covariates = c("covar1", "covar2")
|
||
| 104 | +417 |
- #'+ #' ), |
||
| 105 | +418 |
- #' @keywords internal+ #' data = dta_bladder |
||
| 106 | +419 |
- a_test_proportion_diff <- make_afun(+ #' ) |
||
| 107 | +420 |
- s_test_proportion_diff,+ #' |
||
| 108 | +421 |
- .formats = c(pval = "x.xxxx | (<0.0001)"),+ #' @export |
||
| 109 | +422 |
- .indent_mods = c(pval = 1L)+ fit_coxreg_multivar <- function(variables, |
||
| 110 | +423 |
- )+ data, |
||
| 111 | +424 |
-
+ control = control_coxreg()) {
|
||
| 112 | -+ | |||
| 425 | +83x |
- #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments+ checkmate::assert_list(variables, names = "named") |
||
| 113 | -+ | |||
| 426 | +83x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ has_arm <- "arm" %in% names(variables) |
||
| 114 | -+ | |||
| 427 | +83x |
- #'+ arm_name <- if (has_arm) "arm" else NULL |
||
| 115 | +428 |
- #' @return+ |
||
| 116 | -+ | |||
| 429 | +83x |
- #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ if (!is.null(variables$covariates)) {
|
||
| 117 | -+ | |||
| 430 | +21x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ checkmate::assert_character(variables$covariates) |
||
| 118 | +431 |
- #' the statistics from `s_test_proportion_diff()` to the table layout.+ } |
||
| 119 | +432 |
- #'+ |
||
| 120 | -+ | |||
| 433 | +83x |
- #' @examples+ checkmate::assert_false(control$interaction) |
||
| 121 | -+ | |||
| 434 | +83x |
- #' dta <- data.frame(+ assert_df_with_variables(data, variables) |
||
| 122 | -+ | |||
| 435 | +83x |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
||
| 123 | +436 |
- #' grp = factor(rep(c("A", "B"), each = 50)),
+
|
||
| 124 | -+ | |||
| 437 | +83x |
- #' strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
+ if (!is.null(variables$strata)) {
|
||
| 125 | -+ | |||
| 438 | +3x |
- #' )+ checkmate::assert_disjunct(control$pval_method, "likelihood") |
||
| 126 | +439 |
- #'+ } |
||
| 127 | +440 |
- #' # With `rtables` pipelines.+ |
||
| 128 | -+ | |||
| 441 | +82x |
- #' l <- basic_table() %>%+ form <- h_coxreg_multivar_formula(variables) |
||
| 129 | -+ | |||
| 442 | +82x |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ mod <- survival::coxph( |
||
| 130 | -+ | |||
| 443 | +82x |
- #' test_proportion_diff(+ formula = stats::as.formula(form), |
||
| 131 | -+ | |||
| 444 | +82x |
- #' vars = "rsp",+ data = data, |
||
| 132 | -+ | |||
| 445 | +82x |
- #' method = "cmh", variables = list(strata = "strata")+ ties = control$ties |
||
| 133 | +446 |
- #' )+ ) |
||
| 134 | -+ | |||
| 447 | +82x |
- #'+ structure( |
||
| 135 | -+ | |||
| 448 | +82x |
- #' build_table(l, df = dta)+ list( |
||
| 136 | -+ | |||
| 449 | +82x |
- #'+ mod = mod, |
||
| 137 | -+ | |||
| 450 | +82x |
- #' @export+ data = data, |
||
| 138 | -+ | |||
| 451 | +82x |
- #' @order 2+ control = control, |
||
| 139 | -+ | |||
| 452 | +82x |
- test_proportion_diff <- function(lyt,+ vars = variables |
||
| 140 | +453 |
- vars,+ ), |
||
| 141 | -+ | |||
| 454 | +82x |
- variables = list(strata = NULL),+ class = "coxreg.multivar" |
||
| 142 | +455 |
- method = c("chisq", "schouten", "fisher", "cmh"),
+ ) |
||
| 143 | +456 |
- na_str = default_na_str(),+ } |
||
| 144 | +457 |
- nested = TRUE,+ |
||
| 145 | +458 |
- ...,+ #' Muffled `car::Anova` |
||
| 146 | +459 |
- var_labels = vars,+ #' |
||
| 147 | +460 |
- show_labels = "hidden",+ #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when |
||
| 148 | +461 |
- table_names = vars,+ #' present, this function deliberately muffles this message. |
||
| 149 | +462 |
- .stats = NULL,+ #' |
||
| 150 | +463 |
- .formats = NULL,+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
||
| 151 | +464 |
- .labels = NULL,+ #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
||
| 152 | +465 |
- .indent_mods = NULL) {
+ #' |
||
| 153 | -6x | +|||
| 466 | +
- extra_args <- list(variables = variables, method = method, ...)+ #' @return The output of [car::Anova()], with convergence message muffled. |
|||
| 154 | +467 |
-
+ #' |
||
| 155 | -6x | +|||
| 468 | +
- afun <- make_afun(+ #' @keywords internal |
|||
| 156 | -6x | +|||
| 469 | +
- a_test_proportion_diff,+ muffled_car_anova <- function(mod, test_statistic) {
|
|||
| 157 | -6x | +470 | +219x |
- .stats = .stats,+ tryCatch( |
| 158 | -6x | +471 | +219x |
- .formats = .formats,+ withCallingHandlers( |
| 159 | -6x | +472 | +219x |
- .labels = .labels,+ expr = {
|
| 160 | -6x | +473 | +219x |
- .indent_mods = .indent_mods+ car::Anova( |
| 161 | -+ | |||
| 474 | +219x |
- )+ mod, |
||
| 162 | -6x | +475 | +219x |
- analyze(+ test.statistic = test_statistic, |
| 163 | -6x | +476 | +219x |
- lyt,+ type = "III" |
| 164 | -6x | +|||
| 477 | +
- vars,+ ) |
|||
| 165 | -6x | +|||
| 478 | +
- afun = afun,+ }, |
|||
| 166 | -6x | +479 | +219x |
- var_labels = var_labels,+ message = function(m) invokeRestart("muffleMessage"),
|
| 167 | -6x | +480 | +219x |
- na_str = na_str,+ error = function(e) {
|
| 168 | -6x | +481 | +1x |
- nested = nested,+ stop(paste( |
| 169 | -6x | +482 | +1x |
- extra_args = extra_args,+ "the model seems to have convergence problems, please try to change", |
| 170 | -6x | +483 | +1x |
- show_labels = show_labels,+ "the configuration of covariates or strata variables, e.g.", |
| 171 | -6x | +484 | +1x |
- table_names = table_names+ "- original error:", e |
| 172 | +485 |
- )+ )) |
||
| 173 | +486 |
- }+ } |
||
| 174 | +487 |
-
+ ) |
||
| 175 | +488 |
- #' Helper functions to test proportion differences- |
- ||
| 176 | -- |
- #'- |
- ||
| 177 | -- |
- #' Helper functions to implement various tests on the difference between two proportions.- |
- ||
| 178 | -- |
- #'- |
- ||
| 179 | -- |
- #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns.- |
- ||
| 180 | -- |
- #'- |
- ||
| 181 | -- |
- #' @return A p-value.- |
- ||
| 182 | -- |
- #'- |
- ||
| 183 | -- |
- #' @seealso [prop_diff_test()] for implementation of these helper functions.- |
- ||
| 184 | -- |
- #'- |
- ||
| 185 | -- |
- #' @name h_prop_diff_test- |
- ||
| 186 | -- |
- NULL- |
- ||
| 187 | -- | - - | -||
| 188 | -- |
- #' @describeIn h_prop_diff_test Performs Chi-Squared test. Internally calls [stats::prop.test()].- |
- ||
| 189 | -- |
- #'- |
- ||
| 190 | -- |
- #' @keywords internal- |
- ||
| 191 | -- |
- prop_chisq <- function(tbl) {
- |
- ||
| 192 | -41x | -
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)- |
- ||
| 193 | -41x | -
- tbl <- tbl[, c("TRUE", "FALSE")]
- |
- ||
| 194 | -41x | -
- if (any(colSums(tbl) == 0)) {
- |
- ||
| 195 | -2x | -
- return(1)- |
- ||
| 196 | -- |
- }- |
- ||
| 197 | -39x | -
- stats::prop.test(tbl, correct = FALSE)$p.value- |
- ||
| 198 | -- |
- }- |
- ||
| 199 | -- | - - | -||
| 200 | -- |
- #' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test. Internally calls- |
- ||
| 201 | -- |
- #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded.- |
- ||
| 202 | -- |
- #'- |
- ||
| 203 | -- |
- #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response- |
- ||
| 204 | -- |
- #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.- |
- ||
| 205 | -- |
- #'- |
- ||
| 206 | -- |
- #' @keywords internal- |
- ||
| 207 | -- |
- prop_cmh <- function(ary) {
- |
- ||
| 208 | -16x | -
- checkmate::assert_array(ary)- |
- ||
| 209 | -16x | -
- checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)- |
- ||
| 210 | -16x | -
- checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)- |
- ||
| 211 | -16x | -
- strata_sizes <- apply(ary, MARGIN = 3, sum)- |
- ||
| 212 | -16x | -
- if (any(strata_sizes < 5)) {
- |
- ||
| 213 | -1x | -
- warning("<5 data points in some strata. CMH test may be incorrect.")
- |
- ||
| 214 | -1x | -
- ary <- ary[, , strata_sizes > 1]- |
- ||
| 215 | -- |
- }- |
- ||
| 216 | -- | - - | -||
| 217 | -16x | -
- stats::mantelhaen.test(ary, correct = FALSE)$p.value- |
- ||
| 218 | -- |
- }- |
- ||
| 219 | -- | - - | -||
| 220 | -- |
- #' @describeIn h_prop_diff_test Performs the Chi-Squared test with Schouten correction.- |
- ||
| 221 | -- |
- #'- |
- ||
| 222 | -- |
- #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
- |
- ||
| 223 | -- |
- #'- |
- ||
| 224 | -- |
- #' @keywords internal- |
- ||
| 225 | -- |
- prop_schouten <- function(tbl) {
- |
- ||
| 226 | -100x | -
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)- |
- ||
| 227 | -100x | -
- tbl <- tbl[, c("TRUE", "FALSE")]
- |
- ||
| 228 | -100x | -
- if (any(colSums(tbl) == 0)) {
- |
- ||
| 229 | -1x | -
- return(1)- |
- ||
| 230 | -- |
- }- |
- ||
| 231 | -- | - - | -||
| 232 | -99x | -
- n <- sum(tbl)- |
- ||
| 233 | -99x | -
- n1 <- sum(tbl[1, ])- |
- ||
| 234 | -99x | -
- n2 <- sum(tbl[2, ])- |
- ||
| 235 | -- | - - | -||
| 236 | -99x | -
- ad <- diag(tbl)- |
- ||
| 237 | -99x | -
- bc <- diag(apply(tbl, 2, rev))- |
- ||
| 238 | -99x | -
- ac <- tbl[, 1]- |
- ||
| 239 | -99x | -
- bd <- tbl[, 2]- |
- ||
| 240 | -- | - - | -||
| 241 | -99x | -
- t_schouten <- (n - 1) *- |
- ||
| 242 | -99x | -
- (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /- |
- ||
| 243 | -99x | -
- (n1 * n2 * sum(ac) * sum(bd))- |
- ||
| 244 | -- | - - | -||
| 245 | -99x | -
- 1 - stats::pchisq(t_schouten, df = 1)- |
- ||
| 246 | -- |
- }- |
- ||
| 247 | -- | - - | -||
| 248 | -- |
- #' @describeIn h_prop_diff_test Performs the Fisher's exact test. Internally calls [stats::fisher.test()].- |
- ||
| 249 | -- |
- #'- |
- ||
| 250 | -- |
- #' @keywords internal- |
- ||
| 251 | -- |
- prop_fisher <- function(tbl) {
- |
- ||
| 252 | -2x | -
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)- |
- ||
| 253 | -2x | -
- tbl <- tbl[, c("TRUE", "FALSE")]
- |
- ||
| 254 | -2x | -
- stats::fisher.test(tbl)$p.value+ ) |
||
| 255 | +489 |
}@@ -53513,14 +51724,14 @@ tern coverage - 95.65% |
| 1 |
- #' Helper functions for tabulating survival duration by subgroup+ #' Analyze numeric variables in columns |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' Helper functions that tabulate in a data frame statistics such as median survival+ #' The layout-creating function [analyze_vars_in_cols()] creates a layout element to generate a column-wise |
||
| 6 |
- #' time and hazard ratio for population subgroups.+ #' analysis table. |
||
| 8 |
- #' @inheritParams argument_convention+ #' This function sets the analysis methods as column labels and is a wrapper for [rtables::analyze_colvars()]. |
||
| 9 |
- #' @inheritParams survival_coxph_pairwise+ #' It was designed principally for PK tables. |
||
| 10 |
- #' @inheritParams survival_duration_subgroups+ #' |
||
| 11 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' @inheritParams argument_convention |
||
| 12 |
- #'+ #' @inheritParams rtables::analyze_colvars |
||
| 13 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' @param imp_rule (`string` or `NULL`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can |
||
| 14 |
- #'+ #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order |
||
| 15 |
- #' @examples+ #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()] |
||
| 16 |
- #' library(dplyr)+ #' for more details on imputation. |
||
| 17 |
- #' library(forcats)+ #' @param avalcat_var (`string`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a |
||
| 18 |
- #'+ #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of |
||
| 19 |
- #' adtte <- tern_ex_adtte+ #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable |
||
| 20 |
- #'+ #' used to calculate the `n_blq` statistic (if included in `.stats`). |
||
| 21 |
- #' # Save variable labels before data processing steps.+ #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will |
||
| 22 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is |
||
| 23 |
- #'+ #' used for multiple tables with different data. Defaults to `FALSE`. |
||
| 24 |
- #' adtte_f <- adtte %>%+ #' @param row_labels (`character`)\cr as this function works in columns space, usually `.labels` |
||
| 25 |
- #' filter(+ #' character vector applies on the column space. You can change the row labels by defining this |
||
| 26 |
- #' PARAMCD == "OS",+ #' parameter to a named character vector with names corresponding to the split values. It defaults |
||
| 27 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label. |
||
| 28 |
- #' SEX %in% c("M", "F")
+ #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current |
||
| 29 |
- #' ) %>%+ #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr` |
||
| 30 |
- #' mutate(+ #' to define row labels. This behavior is not supported as we never need to overload row labels. |
||
| 31 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns. |
||
| 32 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ #' This option allows you to add multiple instances of this functions, also in a nested fashion, |
||
| 33 |
- #' SEX = droplevels(SEX),+ #' without adding more splits. This split must happen only one time on a single layout. |
||
| 34 |
- #' is_event = CNSR == 0+ #' |
||
| 35 |
- #' )+ #' @return |
||
| 36 |
- #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 37 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
||
| 38 |
- #'+ #' in columns, and add it to the table layout. |
||
| 39 |
- #' @name h_survival_duration_subgroups+ #' |
||
| 40 |
- NULL+ #' @note |
||
| 41 |
-
+ #' * This is an experimental implementation of [rtables::summarize_row_groups()] and [rtables::analyze_colvars()] |
||
| 42 |
- #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame of median survival times by arm.+ #' that may be subjected to changes as `rtables` extends its support to more complex analysis pipelines in the |
||
| 43 |
- #'+ #' column space. We encourage users to read the examples carefully and file issues for different use cases. |
||
| 44 |
- #' @return+ #' * In this function, `labelstr` behaves atypically. If `labelstr = NULL` (the default), row labels are assigned |
||
| 45 |
- #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`.+ #' automatically as the split values if `do_summarize_row_groups = FALSE` (the default), and as the group label |
||
| 46 |
- #'+ #' if `do_summarize_row_groups = TRUE`. |
||
| 47 |
- #' @examples+ #' |
||
| 48 |
- #' # Extract median survival time for one group.+ #' @seealso [analyze_vars()], [rtables::analyze_colvars()]. |
||
| 49 |
- #' h_survtime_df(+ #' |
||
| 50 |
- #' tte = adtte_f$AVAL,+ #' @examples |
||
| 51 |
- #' is_event = adtte_f$is_event,+ #' library(dplyr) |
||
| 52 |
- #' arm = adtte_f$ARM+ #' |
||
| 53 |
- #' )+ #' # Data preparation |
||
| 54 |
- #'+ #' adpp <- tern_ex_adpp %>% h_pkparam_sort() |
||
| 55 |
- #' @export+ #' |
||
| 56 |
- h_survtime_df <- function(tte, is_event, arm) {
+ #' lyt <- basic_table() %>% |
||
| 57 | -79x | +
- checkmate::assert_numeric(tte)+ #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>% |
|
| 58 | -78x | +
- checkmate::assert_logical(is_event, len = length(tte))+ #' split_rows_by( |
|
| 59 | -78x | +
- assert_valid_factor(arm, len = length(tte))+ #' var = "SEX", |
|
| 60 |
-
+ #' label_pos = "topleft", |
||
| 61 | -78x | +
- df_tte <- data.frame(+ #' child_labels = "hidden" |
|
| 62 | -78x | +
- tte = tte,+ #' ) %>% # Removes duplicated labels |
|
| 63 | -78x | +
- is_event = is_event,+ #' analyze_vars_in_cols(vars = "AGE") |
|
| 64 | -78x | +
- stringsAsFactors = FALSE+ #' result <- build_table(lyt = lyt, df = adpp) |
|
| 65 |
- )+ #' result |
||
| 66 |
-
+ #' |
||
| 67 |
- # Delete NAs+ #' # By selecting just some statistics and ad-hoc labels |
||
| 68 | -78x | +
- non_missing_rows <- stats::complete.cases(df_tte)+ #' lyt <- basic_table() %>% |
|
| 69 | -78x | +
- df_tte <- df_tte[non_missing_rows, ]+ #' split_rows_by(var = "ARM", label_pos = "topleft") %>% |
|
| 70 | -78x | +
- arm <- arm[non_missing_rows]+ #' split_rows_by( |
|
| 71 |
-
+ #' var = "SEX", |
||
| 72 | -78x | +
- lst_tte <- split(df_tte, arm)+ #' label_pos = "topleft", |
|
| 73 | -78x | +
- lst_results <- Map(function(x, arm) {
+ #' child_labels = "hidden", |
|
| 74 | -156x | +
- if (nrow(x) > 0) {
+ #' split_fun = drop_split_levels |
|
| 75 | -152x | +
- s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event")+ #' ) %>% |
|
| 76 | -152x | +
- median_est <- unname(as.numeric(s_surv$median))+ #' analyze_vars_in_cols( |
|
| 77 | -152x | +
- n_events <- sum(x$is_event)+ #' vars = "AGE", |
|
| 78 |
- } else {
+ #' .stats = c("n", "cv", "geom_mean"),
|
||
| 79 | -4x | +
- median_est <- NA+ #' .labels = c( |
|
| 80 | -4x | +
- n_events <- NA+ #' n = "aN", |
|
| 81 |
- }+ #' cv = "aCV", |
||
| 82 |
-
+ #' geom_mean = "aGeomMean" |
||
| 83 | -156x | +
- data.frame(+ #' ) |
|
| 84 | -156x | +
- arm = arm,+ #' ) |
|
| 85 | -156x | +
- n = nrow(x),+ #' result <- build_table(lyt = lyt, df = adpp) |
|
| 86 | -156x | +
- n_events = n_events,+ #' result |
|
| 87 | -156x | +
- median = median_est,+ #' |
|
| 88 | -156x | +
- stringsAsFactors = FALSE+ #' # Changing row labels |
|
| 89 |
- )+ #' lyt <- basic_table() %>% |
||
| 90 | -78x | +
- }, lst_tte, names(lst_tte))+ #' analyze_vars_in_cols( |
|
| 91 |
-
+ #' vars = "AGE", |
||
| 92 | -78x | +
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ #' row_labels = "some custom label" |
|
| 93 | -78x | +
- df$arm <- factor(df$arm, levels = levels(arm))+ #' ) |
|
| 94 | -78x | +
- df+ #' result <- build_table(lyt, df = adpp) |
|
| 95 |
- }+ #' result |
||
| 96 |
-
+ #' |
||
| 97 |
- #' @describeIn h_survival_duration_subgroups Summarizes median survival times by arm and across subgroups+ #' # Pharmacokinetic parameters |
||
| 98 |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ #' lyt <- basic_table() %>% |
||
| 99 |
- #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ #' split_rows_by( |
||
| 100 |
- #' groupings for `subgroups` variables.+ #' var = "TLG_DISPLAY", |
||
| 101 |
- #'+ #' split_label = "PK Parameter", |
||
| 102 |
- #' @return+ #' label_pos = "topleft", |
||
| 103 |
- #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`,+ #' child_labels = "hidden" |
||
| 104 |
- #' `var`, `var_label`, and `row_type`.+ #' ) %>% |
||
| 105 |
- #'+ #' analyze_vars_in_cols( |
||
| 106 |
- #' @examples+ #' vars = "AVAL" |
||
| 107 |
- #' # Extract median survival time for multiple groups.+ #' ) |
||
| 108 |
- #' h_survtime_subgroups_df(+ #' result <- build_table(lyt, df = adpp) |
||
| 109 |
- #' variables = list(+ #' result |
||
| 110 |
- #' tte = "AVAL",+ #' |
||
| 111 |
- #' is_event = "is_event",+ #' # Multiple calls (summarize label and analyze underneath) |
||
| 112 |
- #' arm = "ARM",+ #' lyt <- basic_table() %>% |
||
| 113 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' split_rows_by( |
||
| 114 |
- #' ),+ #' var = "TLG_DISPLAY", |
||
| 115 |
- #' data = adtte_f+ #' split_label = "PK Parameter", |
||
| 116 |
- #' )+ #' label_pos = "topleft" |
||
| 117 |
- #'+ #' ) %>% |
||
| 118 |
- #' # Define groupings for BMRKR2 levels.+ #' analyze_vars_in_cols( |
||
| 119 |
- #' h_survtime_subgroups_df(+ #' vars = "AVAL", |
||
| 120 |
- #' variables = list(+ #' do_summarize_row_groups = TRUE # does a summarize level |
||
| 121 |
- #' tte = "AVAL",+ #' ) %>% |
||
| 122 |
- #' is_event = "is_event",+ #' split_rows_by("SEX",
|
||
| 123 |
- #' arm = "ARM",+ #' child_labels = "hidden", |
||
| 124 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' label_pos = "topleft" |
||
| 125 |
- #' ),+ #' ) %>% |
||
| 126 |
- #' data = adtte_f,+ #' analyze_vars_in_cols( |
||
| 127 |
- #' groups_lists = list(+ #' vars = "AVAL", |
||
| 128 |
- #' BMRKR2 = list(+ #' split_col_vars = FALSE # avoids re-splitting the columns |
||
| 129 |
- #' "low" = "LOW",+ #' ) |
||
| 130 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' result <- build_table(lyt, df = adpp) |
||
| 131 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' result |
||
| 132 |
- #' )+ #' |
||
| 133 |
- #' )+ #' @export |
||
| 134 |
- #' )+ analyze_vars_in_cols <- function(lyt, |
||
| 135 |
- #'+ vars, |
||
| 136 |
- #' @export+ ..., |
||
| 137 |
- h_survtime_subgroups_df <- function(variables,+ .stats = c( |
||
| 138 |
- data,+ "n", |
||
| 139 |
- groups_lists = list(),+ "mean", |
||
| 140 |
- label_all = "All Patients") {
+ "sd", |
||
| 141 | -15x | +
- checkmate::assert_character(variables$tte)+ "se", |
|
| 142 | -15x | +
- checkmate::assert_character(variables$is_event)+ "cv", |
|
| 143 | -15x | +
- checkmate::assert_character(variables$arm)+ "geom_cv" |
|
| 144 | -15x | +
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ ), |
|
| 145 |
-
+ .labels = c( |
||
| 146 | -15x | +
- assert_df_with_variables(data, variables)+ n = "n", |
|
| 147 |
-
+ mean = "Mean", |
||
| 148 | -15x | +
- checkmate::assert_string(label_all)+ sd = "SD", |
|
| 149 |
-
+ se = "SE", |
||
| 150 |
- # Add All Patients.+ cv = "CV (%)", |
||
| 151 | -15x | +
- result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]])+ geom_cv = "CV % Geometric Mean" |
|
| 152 | -15x | +
- result_all$subgroup <- label_all+ ), |
|
| 153 | -15x | +
- result_all$var <- "ALL"+ row_labels = NULL, |
|
| 154 | -15x | +
- result_all$var_label <- label_all+ do_summarize_row_groups = FALSE, |
|
| 155 | -15x | +
- result_all$row_type <- "content"+ split_col_vars = TRUE, |
|
| 156 |
-
+ imp_rule = NULL, |
||
| 157 |
- # Add Subgroups.+ avalcat_var = "AVALCAT1", |
||
| 158 | -15x | +
- if (is.null(variables$subgroups)) {
+ cache = FALSE, |
|
| 159 | -3x | +
- result_all+ .indent_mods = NULL, |
|
| 160 |
- } else {
+ na_str = default_na_str(), |
||
| 161 | -12x | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ nested = TRUE, |
|
| 162 | -12x | +
- l_result <- lapply(l_data, function(grp) {
+ .formats = NULL, |
|
| 163 | -60x | +
- result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]])+ .aligns = NULL) {
|
|
| 164 | -60x | +26x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ extra_args <- list(...) |
| 165 | -60x | +
- cbind(result, result_labels)+ |
|
| 166 | -+ | 26x |
- })+ checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE) |
| 167 | -12x | +26x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ checkmate::assert_character(row_labels, null.ok = TRUE) |
| 168 | -12x | +26x |
- result_subgroups$row_type <- "analysis"+ checkmate::assert_int(.indent_mods, null.ok = TRUE) |
| 169 | -12x | +26x |
- rbind(+ checkmate::assert_flag(nested) |
| 170 | -12x | +26x |
- result_all,+ checkmate::assert_flag(split_col_vars) |
| 171 | -12x | +26x |
- result_subgroups+ checkmate::assert_flag(do_summarize_row_groups) |
| 172 |
- )+ |
||
| 173 |
- }+ # Filtering |
||
| 174 | -+ | 26x |
- }+ met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
|
| 175 | -+ | 26x |
-
+ .stats <- get_stats(met_grps, stats_in = .stats) |
| 176 | -+ | 26x |
- #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame with estimates of+ formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats) |
| 177 | -+ | 26x |
- #' treatment hazard ratio.+ labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels) |
| 178 | -+ | ! |
- #'+ if ("control" %in% names(extra_args)) labels_v <- labels_v %>% labels_use_control(extra_args[["control"]], .labels)
|
| 179 |
- #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed.+ |
||
| 180 |
- #'+ # Check for vars in the case that one or more are used |
||
| 181 | -+ | 26x |
- #' @return+ if (length(vars) == 1) {
|
| 182 | -+ | 21x |
- #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`,+ vars <- rep(vars, length(.stats)) |
| 183 | -+ | 5x |
- #' `conf_level`, `pval` and `pval_label`.+ } else if (length(vars) != length(.stats)) {
|
| 184 | -+ | 1x |
- #'+ stop( |
| 185 | -+ | 1x |
- #' @examples+ "Analyzed variables (vars) does not have the same ", |
| 186 | -+ | 1x |
- #' # Extract hazard ratio for one group.+ "number of elements of specified statistics (.stats)." |
| 187 |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM)+ ) |
||
| 188 |
- #'+ } |
||
| 189 |
- #' # Extract hazard ratio for one group with stratification factor.+ |
||
| 190 | -+ | 25x |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1)+ if (split_col_vars) {
|
| 191 |
- #'+ # Checking there is not a previous identical column split |
||
| 192 | -+ | 21x |
- #' @export+ clyt <- tail(clayout(lyt), 1)[[1]] |
| 193 |
- h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
+
|
||
| 194 | -85x | +21x |
- checkmate::assert_numeric(tte)+ dummy_lyt <- split_cols_by_multivar( |
| 195 | -85x | +21x |
- checkmate::assert_logical(is_event, len = length(tte))+ lyt = basic_table(), |
| 196 | -85x | +21x |
- assert_valid_factor(arm, n.levels = 2, len = length(tte))+ vars = vars, |
| 197 | -+ | 21x |
-
+ varlabels = labels_v |
| 198 | -85x | +
- df_tte <- data.frame(tte = tte, is_event = is_event)+ ) |
|
| 199 | -85x | +
- strata_vars <- NULL+ |
|
| 200 | -+ | 21x |
-
+ if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
|
| 201 | -85x | +2x |
- if (!is.null(strata_data)) {
+ stop( |
| 202 | -5x | +2x |
- if (is.data.frame(strata_data)) {
+ "Column split called again with the same values. ", |
| 203 | -4x | +2x |
- strata_vars <- names(strata_data)+ "This can create many unwanted columns. Please consider adding ", |
| 204 | -4x | +2x |
- checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))+ "split_col_vars = FALSE to the last call of ", |
| 205 | -4x | +2x |
- assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars)))+ deparse(sys.calls()[[sys.nframe() - 1]]), "." |
| 206 |
- } else {
+ ) |
||
| 207 | -1x | +
- assert_valid_factor(strata_data, len = nrow(df_tte))+ } |
|
| 208 | -1x | +
- strata_vars <- "strata_data"+ |
|
| 209 |
- }+ # Main col split |
||
| 210 | -5x | +19x |
- df_tte[strata_vars] <- strata_data+ lyt <- split_cols_by_multivar( |
| 211 | -+ | 19x |
- }+ lyt = lyt, |
| 212 | -+ | 19x |
-
+ vars = vars, |
| 213 | -85x | +19x |
- l_df <- split(df_tte, arm)+ varlabels = labels_v |
| 214 |
-
+ ) |
||
| 215 | -85x | +
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ } |
|
| 216 |
- # Hazard ratio and CI.+ |
||
| 217 | -79x | +23x |
- result <- s_coxph_pairwise(+ env <- new.env() # create caching environment |
| 218 | -79x | +
- df = l_df[[2]],+ |
|
| 219 | -79x | +23x |
- .ref_group = l_df[[1]],+ if (do_summarize_row_groups) {
|
| 220 | -79x | +8x |
- .in_ref_col = FALSE,+ if (length(unique(vars)) > 1) {
|
| 221 | -79x | +! |
- .var = "tte",+ stop("When using do_summarize_row_groups only one label level var should be inserted.")
|
| 222 | -79x | +
- is_event = "is_event",+ } |
|
| 223 | -79x | +
- strata = strata_vars,+ |
|
| 224 | -79x | +
- control = control+ # Function list for do_summarize_row_groups. Slightly different handling of labels |
|
| 225 | -+ | 8x |
- )+ cfun_list <- Map( |
| 226 | -+ | 8x |
-
+ function(stat, use_cache, cache_env) {
|
| 227 | -79x | +48x |
- df <- data.frame(+ function(u, .spl_context, labelstr, .df_row, ...) {
|
| 228 |
- # Dummy column needed downstream to create a nested header.+ # Statistic |
||
| 229 | -79x | +152x |
- arm = " ",+ var_row_val <- paste( |
| 230 | -79x | +152x |
- n_tot = unname(as.numeric(result$n_tot)),+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
| 231 | -79x | +152x |
- n_tot_events = unname(as.numeric(result$n_tot_events)),+ paste(.spl_context$value, collapse = "_"), |
| 232 | -79x | +152x |
- hr = unname(as.numeric(result$hr)),+ sep = "_" |
| 233 | -79x | +
- lcl = unname(result$hr_ci[1]),+ ) |
|
| 234 | -79x | +152x |
- ucl = unname(result$hr_ci[2]),+ if (use_cache) {
|
| 235 | -79x | +! |
- conf_level = control[["conf_level"]],+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
| 236 | -79x | +! |
- pval = as.numeric(result$pvalue),+ x_stats <- cache_env[[var_row_val]] |
| 237 | -79x | +
- pval_label = obj_label(result$pvalue),+ } else {
|
|
| 238 | -79x | +152x |
- stringsAsFactors = FALSE+ x_stats <- s_summary(u, ...) |
| 239 |
- )+ } |
||
| 240 |
- } else if (+ |
||
| 241 | -6x | +152x |
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
| 242 | -6x | +152x |
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ res <- x_stats[[stat]] |
| 243 |
- ) {
+ } else {
|
||
| 244 | -6x | +! |
- df_tte_complete <- df_tte[stats::complete.cases(df_tte), ]+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
| 245 | -6x | +! |
- df <- data.frame(+ res_imp <- imputation_rule( |
| 246 | -+ | ! |
- # Dummy column needed downstream to create a nested header.+ .df_row, x_stats, stat, |
| 247 | -6x | +! |
- arm = " ",+ imp_rule = imp_rule, |
| 248 | -6x | +! |
- n_tot = nrow(df_tte_complete),+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
|
| 249 | -6x | +! |
- n_tot_events = sum(df_tte_complete$is_event),+ avalcat_var = avalcat_var |
| 250 | -6x | +
- hr = NA,+ ) |
|
| 251 | -6x | +! |
- lcl = NA,+ res <- res_imp[["val"]] |
| 252 | -6x | +! |
- ucl = NA,+ na_str <- res_imp[["na_str"]] |
| 253 | -6x | +
- conf_level = control[["conf_level"]],+ } |
|
| 254 | -6x | +
- pval = NA,+ |
|
| 255 | -6x | +
- pval_label = NA,+ # Label check and replacement |
|
| 256 | -6x | +152x |
- stringsAsFactors = FALSE+ if (length(row_labels) > 1) {
|
| 257 | -+ | 32x |
- )+ if (!(labelstr %in% names(row_labels))) {
|
| 258 | -+ | 2x |
- } else {
+ stop( |
| 259 | -! | +2x |
- df <- data.frame(+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
| 260 | -+ | 2x |
- # Dummy column needed downstream to create a nested header.+ "that contains the split values. In the current split variable ", |
| 261 | -! | +2x |
- arm = " ",+ .spl_context$split[nrow(.spl_context)], |
| 262 | -! | +2x |
- n_tot = 0L,+ " the labelstr value (split value by default) ", labelstr, " is not in", |
| 263 | -! | +2x |
- n_tot_events = 0L,+ " row_labels names: ", names(row_labels) |
| 264 | -! | +
- hr = NA,+ ) |
|
| 265 | -! | +
- lcl = NA,+ } |
|
| 266 | -! | +30x |
- ucl = NA,+ lbl <- unlist(row_labels[labelstr]) |
| 267 | -! | +
- conf_level = control[["conf_level"]],+ } else {
|
|
| 268 | -! | +120x |
- pval = NA,+ lbl <- labelstr |
| 269 | -! | +
- pval_label = NA,+ } |
|
| 270 | -! | +
- stringsAsFactors = FALSE+ |
|
| 271 |
- )+ # Cell creation |
||
| 272 | -+ | 150x |
- }+ rcell(res, |
| 273 | -+ | 150x |
-
+ label = lbl, |
| 274 | -85x | +150x |
- df+ format = formats_v[names(formats_v) == stat][[1]], |
| 275 | -+ | 150x |
- }+ format_na_str = na_str, |
| 276 | -+ | 150x |
-
+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
| 277 | -+ | 150x |
- #' @describeIn h_survival_duration_subgroups Summarizes estimates of the treatment hazard ratio+ align = .aligns |
| 278 |
- #' across subgroups in a data frame. `variables` corresponds to the names of variables found in+ ) |
||
| 279 |
- #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and+ } |
||
| 280 |
- #' optionally `subgroups` and `strata`. `groups_lists` optionally specifies+ }, |
||
| 281 | -+ | 8x |
- #' groupings for `subgroups` variables.+ stat = .stats, |
| 282 | -+ | 8x |
- #'+ use_cache = cache, |
| 283 | -+ | 8x |
- #' @return+ cache_env = replicate(length(.stats), env) |
| 284 |
- #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`,+ ) |
||
| 285 |
- #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ |
||
| 286 |
- #'+ # Main call to rtables |
||
| 287 | -+ | 8x |
- #' @examples+ summarize_row_groups( |
| 288 | -+ | 8x |
- #' # Extract hazard ratio for multiple groups.+ lyt = lyt, |
| 289 | -+ | 8x |
- #' h_coxph_subgroups_df(+ var = unique(vars), |
| 290 | -+ | 8x |
- #' variables = list(+ cfun = cfun_list, |
| 291 | -+ | 8x |
- #' tte = "AVAL",+ na_str = na_str, |
| 292 | -+ | 8x |
- #' is_event = "is_event",+ extra_args = extra_args |
| 293 |
- #' arm = "ARM",+ ) |
||
| 294 |
- #' subgroups = c("SEX", "BMRKR2")
+ } else {
|
||
| 295 |
- #' ),+ # Function list for analyze_colvars |
||
| 296 | -+ | 15x |
- #' data = adtte_f+ afun_list <- Map( |
| 297 | -+ | 15x |
- #' )+ function(stat, use_cache, cache_env) {
|
| 298 | -+ | 76x |
- #'+ function(u, .spl_context, .df_row, ...) {
|
| 299 |
- #' # Define groupings of BMRKR2 levels.+ # Main statistics |
||
| 300 | -+ | 468x |
- #' h_coxph_subgroups_df(+ var_row_val <- paste( |
| 301 | -+ | 468x |
- #' variables = list(+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
| 302 | -+ | 468x |
- #' tte = "AVAL",+ paste(.spl_context$value, collapse = "_"), |
| 303 | -+ | 468x |
- #' is_event = "is_event",+ sep = "_" |
| 304 |
- #' arm = "ARM",+ ) |
||
| 305 | -+ | 468x |
- #' subgroups = c("SEX", "BMRKR2")
+ if (use_cache) {
|
| 306 | -+ | 16x |
- #' ),+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
| 307 | -+ | 56x |
- #' data = adtte_f,+ x_stats <- cache_env[[var_row_val]] |
| 308 |
- #' groups_lists = list(+ } else {
|
||
| 309 | -+ | 412x |
- #' BMRKR2 = list(+ x_stats <- s_summary(u, ...) |
| 310 |
- #' "low" = "LOW",+ } |
||
| 311 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+
|
||
| 312 | -+ | 468x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
| 313 | -+ | 348x |
- #' )+ res <- x_stats[[stat]] |
| 314 |
- #' )+ } else {
|
||
| 315 | -+ | 120x |
- #' )+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
| 316 | -+ | 120x |
- #'+ res_imp <- imputation_rule( |
| 317 | -+ | 120x |
- #' # Extract hazard ratio for multiple groups with stratification factors.+ .df_row, x_stats, stat, |
| 318 | -+ | 120x |
- #' h_coxph_subgroups_df(+ imp_rule = imp_rule, |
| 319 | -+ | 120x |
- #' variables = list(+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
|
| 320 | -+ | 120x |
- #' tte = "AVAL",+ avalcat_var = avalcat_var |
| 321 |
- #' is_event = "is_event",+ ) |
||
| 322 | -+ | 120x |
- #' arm = "ARM",+ res <- res_imp[["val"]] |
| 323 | -+ | 120x |
- #' subgroups = c("SEX", "BMRKR2"),
+ na_str <- res_imp[["na_str"]] |
| 324 |
- #' strata = c("STRATA1", "STRATA2")
+ } |
||
| 325 |
- #' ),+ |
||
| 326 | -+ | 468x |
- #' data = adtte_f+ if (is.list(res)) {
|
| 327 | -+ | 19x |
- #' )+ if (length(res) > 1) {
|
| 328 | -+ | 1x |
- #'+ stop("The analyzed column produced more than one category of results.")
|
| 329 |
- #' @export+ } else {
|
||
| 330 | -+ | 18x |
- h_coxph_subgroups_df <- function(variables,+ res <- unlist(res) |
| 331 |
- data,+ } |
||
| 332 |
- groups_lists = list(),+ } |
||
| 333 |
- control = control_coxph(),+ |
||
| 334 |
- label_all = "All Patients") {
+ # Label from context |
||
| 335 | -17x | +467x |
- if ("strat" %in% names(variables)) {
+ label_from_context <- .spl_context$value[nrow(.spl_context)] |
| 336 | -! | +
- warning(+ |
|
| 337 | -! | +
- "Warning: the `strat` element name of the `variables` list argument to `h_coxph_subgroups_df() ",+ # Label switcher |
|
| 338 | -! | +467x |
- "was deprecated in tern 0.9.4.\n ",+ if (is.null(row_labels)) {
|
| 339 | -! | +387x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ lbl <- label_from_context |
| 340 |
- )+ } else {
|
||
| 341 | -! | +80x |
- variables[["strata"]] <- variables[["strat"]]+ if (length(row_labels) > 1) {
|
| 342 | -+ | 68x |
- }+ if (!(label_from_context %in% names(row_labels))) {
|
| 343 | -+ | 2x |
-
+ stop( |
| 344 | -17x | +2x |
- checkmate::assert_character(variables$tte)+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
| 345 | -17x | +2x |
- checkmate::assert_character(variables$is_event)+ "that contains the split values. In the current split variable ", |
| 346 | -17x | +2x |
- checkmate::assert_character(variables$arm)+ .spl_context$split[nrow(.spl_context)], |
| 347 | -17x | +2x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ " the split value ", label_from_context, " is not in", |
| 348 | -17x | +2x |
- checkmate::assert_character(variables$strata, null.ok = TRUE)+ " row_labels names: ", names(row_labels) |
| 349 | -17x | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ ) |
|
| 350 | -17x | +
- assert_df_with_variables(data, variables)+ } |
|
| 351 | -17x | +66x |
- checkmate::assert_string(label_all)+ lbl <- unlist(row_labels[label_from_context]) |
| 352 |
-
+ } else {
|
||
| 353 | -+ | 12x |
- # Add All Patients.+ lbl <- row_labels |
| 354 | -17x | +
- result_all <- h_coxph_df(+ } |
|
| 355 | -17x | +
- tte = data[[variables$tte]],+ } |
|
| 356 | -17x | +
- is_event = data[[variables$is_event]],+ |
|
| 357 | -17x | +
- arm = data[[variables$arm]],+ # Cell creation |
|
| 358 | -17x | +465x |
- strata_data = if (is.null(variables$strata)) NULL else data[variables$strata],+ rcell(res, |
| 359 | -17x | +465x |
- control = control+ label = lbl, |
| 360 | -+ | 465x |
- )+ format = formats_v[names(formats_v) == stat][[1]], |
| 361 | -17x | +465x |
- result_all$subgroup <- label_all+ format_na_str = na_str, |
| 362 | -17x | +465x |
- result_all$var <- "ALL"+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
| 363 | -17x | +465x |
- result_all$var_label <- label_all+ align = .aligns |
| 364 | -17x | +
- result_all$row_type <- "content"+ ) |
|
| 365 |
-
+ } |
||
| 366 |
- # Add Subgroups.+ }, |
||
| 367 | -17x | +15x |
- if (is.null(variables$subgroups)) {
+ stat = .stats, |
| 368 | -3x | +15x |
- result_all+ use_cache = cache, |
| 369 | -+ | 15x |
- } else {
+ cache_env = replicate(length(.stats), env) |
| 370 | -14x | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ ) |
|
| 372 | -14x | +
- l_result <- lapply(l_data, function(grp) {
+ # Main call to rtables |
|
| 373 | -64x | +15x |
- result <- h_coxph_df(+ analyze_colvars(lyt, |
| 374 | -64x | +15x |
- tte = grp$df[[variables$tte]],+ afun = afun_list, |
| 375 | -64x | +15x |
- is_event = grp$df[[variables$is_event]],+ na_str = na_str, |
| 376 | -64x | +15x |
- arm = grp$df[[variables$arm]],+ nested = nested, |
| 377 | -64x | +15x |
- strata_data = if (is.null(variables$strata)) NULL else grp$df[variables$strata],+ extra_args = extra_args |
| 378 | -64x | +
- control = control+ ) |
|
| 379 |
- )+ } |
||
| 380 | -64x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ } |
|
| 381 | -64x | +
- cbind(result, result_labels)+ |
|
| 382 |
- })+ # Helper function |
||
| 383 |
-
+ get_last_col_split <- function(lyt) {
|
||
| 384 | -14x | +3x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ tail(tail(clayout(lyt), 1)[[1]], 1)[[1]] |
| 385 | -14x | +
- result_subgroups$row_type <- "analysis"+ } |
| 386 | +1 |
-
+ #' Helper functions for Cox proportional hazards regression |
||
| 387 | -14x | +|||
| 2 | +
- rbind(+ #' |
|||
| 388 | -14x | +|||
| 3 | +
- result_all,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 389 | -14x | +|||
| 4 | +
- result_subgroups+ #' |
|||
| 390 | +5 |
- )+ #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
||
| 391 | +6 |
- }+ #' |
||
| 392 | +7 |
- }+ #' @inheritParams argument_convention |
||
| 393 | +8 |
-
+ #' @inheritParams h_coxreg_univar_extract |
||
| 394 | +9 |
- #' Split data frame by subgroups+ #' @inheritParams cox_regression_inter |
||
| 395 | +10 | ++ |
+ #' @inheritParams control_coxreg+ |
+ |
| 11 |
#' |
|||
| 396 | +12 |
- #' @description `r lifecycle::badge("stable")`
+ #' @seealso [cox_regression] |
||
| 397 | +13 |
#' |
||
| 398 | +14 |
- #' Split a data frame into a non-nested list of subsets.+ #' @name h_cox_regression |
||
| 399 | +15 |
- #'+ NULL |
||
| 400 | +16 |
- #' @inheritParams argument_convention+ |
||
| 401 | +17 |
- #' @inheritParams survival_duration_subgroups+ #' @describeIn h_cox_regression Helper for Cox regression formula. Creates a list of formulas. It is used |
||
| 402 | +18 |
- #' @param data (`data.frame`)\cr dataset to split.+ #' internally by [fit_coxreg_univar()] for the comparison of univariate Cox regression models. |
||
| 403 | +19 |
- #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets.+ #' |
||
| 404 | +20 |
- #' Unused levels not present in `data` are dropped. Note that the order in this vector+ #' @return |
||
| 405 | +21 |
- #' determines the order in the downstream table.+ #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]). |
||
| 406 | +22 |
#' |
||
| 407 | +23 |
- #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`).+ #' @examples |
||
| 408 | +24 | ++ |
+ #' # `h_coxreg_univar_formulas`+ |
+ |
| 25 |
#' |
|||
| 409 | +26 |
- #' @details Main functionality is to prepare data for use in forest plot layouts.+ #' ## Simple formulas. |
||
| 410 | +27 |
- #'+ #' h_coxreg_univar_formulas( |
||
| 411 | +28 |
- #' @examples+ #' variables = list( |
||
| 412 | +29 |
- #' df <- data.frame(+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
|
||
| 413 | +30 |
- #' x = c(1:5),+ #' ) |
||
| 414 | +31 |
- #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
+ #' ) |
||
| 415 | +32 |
- #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
+ #' |
||
| 416 | +33 |
- #' )+ #' ## Addition of an optional strata. |
||
| 417 | +34 |
- #' formatters::var_labels(df) <- paste("label for", names(df))
+ #' h_coxreg_univar_formulas( |
||
| 418 | +35 |
- #'+ #' variables = list( |
||
| 419 | +36 |
- #' h_split_by_subgroups(+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
||
| 420 | +37 |
- #' data = df,+ #' strata = "SITE" |
||
| 421 | +38 |
- #' subgroups = c("y", "z")
+ #' ) |
||
| 422 | +39 |
#' ) |
||
| 423 | +40 |
#' |
||
| 424 | +41 |
- #' h_split_by_subgroups(+ #' ## Inclusion of the interaction term. |
||
| 425 | +42 |
- #' data = df,+ #' h_coxreg_univar_formulas( |
||
| 426 | +43 |
- #' subgroups = c("y", "z"),
+ #' variables = list( |
||
| 427 | +44 |
- #' groups_lists = list(+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
||
| 428 | +45 |
- #' y = list("AB" = c("A", "B"), "C" = "C")
+ #' strata = "SITE" |
||
| 429 | +46 |
- #' )+ #' ), |
||
| 430 | +47 | ++ |
+ #' interaction = TRUE+ |
+ |
| 48 |
#' ) |
|||
| 431 | +49 |
#' |
||
| 432 | +50 |
- #' @export+ #' ## Only covariates fitted in separate models. |
||
| 433 | +51 |
- h_split_by_subgroups <- function(data,+ #' h_coxreg_univar_formulas( |
||
| 434 | +52 |
- subgroups,+ #' variables = list( |
||
| 435 | +53 |
- groups_lists = list()) {
+ #' time = "time", event = "status", covariates = c("X", "y")
|
||
| 436 | -66x | +|||
| 54 | +
- checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)+ #' ) |
|||
| 437 | -66x | +|||
| 55 | +
- checkmate::assert_list(groups_lists, names = "named")+ #' ) |
|||
| 438 | -66x | +|||
| 56 | +
- checkmate::assert_subset(names(groups_lists), subgroups)+ #' |
|||
| 439 | -66x | +|||
| 57 | +
- assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))+ #' @export |
|||
| 440 | +58 |
-
+ h_coxreg_univar_formulas <- function(variables,+ |
+ ||
| 59 | ++ |
+ interaction = FALSE) {
|
||
| 441 | -66x | +60 | +50x |
- data_labels <- unname(formatters::var_labels(data))+ checkmate::assert_list(variables, names = "named") |
| 442 | -66x | +61 | +50x |
- df_subgroups <- data[, subgroups, drop = FALSE]+ has_arm <- "arm" %in% names(variables) |
| 443 | -66x | +62 | +50x |
- subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)+ arm_name <- if (has_arm) "arm" else NULL |
| 444 | +63 | |||
| 445 | -66x | +64 | +50x |
- l_labels <- Map(function(grp_i, name_i) {
+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 446 | -120x | +|||
| 65 | +
- existing_levels <- levels(droplevels(grp_i))+ |
|||
| 447 | -120x | +66 | +50x |
- grp_levels <- if (name_i %in% names(groups_lists)) {
+ checkmate::assert_flag(interaction) |
| 448 | +67 |
- # For this variable groupings are defined. We check which groups are contained in the data.+ |
||
| 449 | -11x | +68 | +50x |
- group_list_i <- groups_lists[[name_i]]+ if (!has_arm || is.null(variables$covariates)) {
|
| 450 | -11x | +69 | +10x |
- group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)+ checkmate::assert_false(interaction) |
| 451 | -11x | +|||
| 70 | +
- names(which(group_has_levels))+ } |
|||
| 452 | +71 |
- } else {
+
|
||
| 453 | -109x | +72 | +48x |
- existing_levels+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
| 454 | +73 |
- }+ |
||
| 455 | -120x | +74 | +48x |
- df_labels <- data.frame(+ if (!is.null(variables$covariates)) {
|
| 456 | -120x | +75 | +47x |
- subgroup = grp_levels,+ forms <- paste0( |
| 457 | -120x | +76 | +47x |
- var = name_i,+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
| 458 | -120x | +77 | +47x |
- var_label = unname(subgroup_labels[name_i]),+ ifelse(has_arm, variables$arm, "1"), |
| 459 | -120x | +78 | +47x |
- stringsAsFactors = FALSE # Rationale is that subgroups may not be unique.+ ifelse(interaction, " * ", " + "), |
| 460 | -+ | |||
| 79 | +47x |
- )+ variables$covariates, |
||
| 461 | -66x | +80 | +47x |
- }, df_subgroups, names(df_subgroups))+ ifelse(+ |
+
| 81 | +47x | +
+ !is.null(variables$strata),+ |
+ ||
| 82 | +47x | +
+ paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
|
||
| 462 | +83 |
-
+ "" |
||
| 463 | +84 |
- # Create a data frame with one row per subgroup.+ ) |
||
| 464 | -66x | +|||
| 85 | +
- df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))+ ) |
|||
| 465 | -66x | +|||
| 86 | +
- row_label <- paste0(df_labels$var, ".", df_labels$subgroup)+ } else {
|
|||
| 466 | -66x | +87 | +1x |
- row_split_var <- factor(row_label, levels = row_label)+ forms <- NULL |
| 467 | +88 |
-
+ } |
||
| 468 | -+ | |||
| 89 | +48x |
- # Create a list of data subsets.+ nams <- variables$covariates |
||
| 469 | -66x | +90 | +48x |
- lapply(split(df_labels, row_split_var), function(row_i) {
+ if (has_arm) {
|
| 470 | -294x | +91 | +41x |
- which_row <- if (row_i$var %in% names(groups_lists)) {
+ ref <- paste0( |
| 471 | -31x | +92 | +41x |
- data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
| 472 | -+ | |||
| 93 | +41x |
- } else {
+ variables$arm, |
||
| 473 | -263x | +94 | +41x |
- data[[row_i$var]] == row_i$subgroup+ ifelse( |
| 474 | -+ | |||
| 95 | +41x |
- }+ !is.null(variables$strata), |
||
| 475 | -294x | +96 | +41x |
- df <- data[which_row, ]+ paste0( |
| 476 | -294x | +97 | +41x |
- rownames(df) <- NULL+ " + strata(", paste0(variables$strata, collapse = ", "), ")"
|
| 477 | -294x | +|||
| 98 | +
- formatters::var_labels(df) <- data_labels+ ), |
|||
| 478 | +99 |
-
+ "" |
||
| 479 | -294x | +|||
| 100 | +
- list(+ )+ |
+ |||
| 101 | ++ |
+ ) |
||
| 480 | -294x | +102 | +41x |
- df = df,+ forms <- c(ref, forms) |
| 481 | -294x | +103 | +41x |
- df_labels = data.frame(row_i, row.names = NULL)+ nams <- c("ref", nams)
|
| 482 | +104 |
- )+ }+ |
+ ||
| 105 | +48x | +
+ stats::setNames(forms, nams) |
||
| 483 | +106 |
- })+ } |
||
| 484 | +107 |
- }+ |
| 1 | +108 |
- #' Individual patient plots+ #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas |
||
| 2 | +109 |
- #'+ #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox |
||
| 3 | +110 |
- #' @description `r lifecycle::badge("stable")`
+ #' regression models. Interactions will not be included in multivariate Cox regression model. |
||
| 4 | +111 |
#' |
||
| 5 | +112 |
- #' Line plot(s) displaying trend in patients' parameter values over time is rendered.+ #' @return |
||
| 6 | +113 |
- #' Patients' individual baseline values can be added to the plot(s) as reference.+ #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]). |
||
| 7 | +114 |
#' |
||
| 8 | +115 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 9 | +116 |
- #' @param xvar (`string`)\cr time point variable to be plotted on x-axis.+ #' # `h_coxreg_multivar_formula` |
||
| 10 | +117 |
- #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis.+ #' |
||
| 11 | +118 |
- #' @param xlab (`string`)\cr plot label for x-axis.+ #' h_coxreg_multivar_formula( |
||
| 12 | +119 |
- #' @param ylab (`string`)\cr plot label for y-axis.+ #' variables = list( |
||
| 13 | +120 |
- #' @param id_var (`string`)\cr variable used as patient identifier.+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
|
||
| 14 | +121 |
- #' @param title (`string`)\cr title for plot.+ #' ) |
||
| 15 | +122 |
- #' @param subtitle (`string`)\cr subtitle for plot.+ #' ) |
||
| 16 | +123 |
- #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on+ #' |
||
| 17 | +124 |
- #' plot when `TRUE`.+ #' # Addition of an optional strata. |
||
| 18 | +125 |
- #' @param yvar_baseline (`string`)\cr variable with baseline values only.+ #' h_coxreg_multivar_formula( |
||
| 19 | +126 |
- #' Ignored when `add_baseline_hline` is `FALSE`.+ #' variables = list( |
||
| 20 | +127 |
- #' @param ggtheme (`theme`)\cr optional graphical theme function as provided+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
|
||
| 21 | +128 |
- #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display.+ #' strata = "SITE" |
||
| 22 | +129 |
- #' @param plotting_choices (`string`)\cr specifies options for displaying+ #' ) |
||
| 23 | +130 |
- #' plots. Must be one of `"all_in_one"`, `"split_by_max_obs"`, or `"separate_by_obs"`.+ #' ) |
||
| 24 | +131 |
- #' @param max_obs_per_plot (`integer(1)`)\cr number of observations to be plotted on one+ #' |
||
| 25 | +132 |
- #' plot. Ignored if `plotting_choices` is not `"separate_by_obs"`.+ #' # Example without treatment arm. |
||
| 26 | +133 |
- #' @param caption (`string`)\cr optional caption below the plot.+ #' h_coxreg_multivar_formula( |
||
| 27 | +134 |
- #' @param col (`character`)\cr line colors.+ #' variables = list( |
||
| 28 | +135 |
- #'+ #' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
|
||
| 29 | +136 |
- #' @seealso Relevant helper function [h_g_ipp()].+ #' strata = "SITE" |
||
| 30 | +137 |
- #'+ #' ) |
||
| 31 | +138 |
- #' @name g_ipp+ #' ) |
||
| 32 | +139 |
- #' @aliases individual_patient_plot+ #' |
||
| 33 | +140 |
- NULL+ #' @export |
||
| 34 | +141 |
-
+ h_coxreg_multivar_formula <- function(variables) {
|
||
| 35 | -+ | |||
| 142 | +89x |
- #' Helper function to create simple line plot over time+ checkmate::assert_list(variables, names = "named") |
||
| 36 | -+ | |||
| 143 | +89x |
- #'+ has_arm <- "arm" %in% names(variables) |
||
| 37 | -+ | |||
| 144 | +89x |
- #' @description `r lifecycle::badge("stable")`
+ arm_name <- if (has_arm) "arm" else NULL |
||
| 38 | +145 |
- #'+ |
||
| 39 | -+ | |||
| 146 | +89x |
- #' Function that generates a simple line plot displaying parameter trends over time.+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
||
| 40 | +147 |
- #'+ |
||
| 41 | -+ | |||
| 148 | +89x |
- #' @inheritParams argument_convention+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
||
| 42 | +149 |
- #' @inheritParams g_ipp+ |
||
| 43 | -+ | |||
| 150 | +89x |
- #'+ y <- paste0( |
||
| 44 | -+ | |||
| 151 | +89x |
- #' @return A `ggplot` line plot.+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ |
+ ||
| 152 | +89x | +
+ ifelse(has_arm, variables$arm, "1") |
||
| 45 | +153 |
- #'+ )+ |
+ ||
| 154 | +89x | +
+ if (length(variables$covariates) > 0) {
+ |
+ ||
| 155 | +26x | +
+ y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ") |
||
| 46 | +156 |
- #' @seealso [g_ipp()] which uses this function.+ }+ |
+ ||
| 157 | +89x | +
+ if (!is.null(variables$strata)) {
+ |
+ ||
| 158 | +5x | +
+ y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
||
| 47 | +159 |
- #'+ }+ |
+ ||
| 160 | +89x | +
+ y |
||
| 48 | +161 |
- #' @examples+ } |
||
| 49 | +162 |
- #' library(dplyr)+ |
||
| 50 | +163 |
- #'+ #' @describeIn h_cox_regression Utility function to help tabulate the result of |
||
| 51 | +164 |
- #' # Select a small sample of data to plot.+ #' a univariate Cox regression model. |
||
| 52 | +165 |
- #' adlb <- tern_ex_adlb %>%+ #' |
||
| 53 | +166 |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ #' @param effect (`string`)\cr the treatment variable. |
||
| 54 | +167 |
- #' slice(1:36)+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
||
| 55 | +168 |
#' |
||
| 56 | +169 |
- #' p <- h_g_ipp(+ #' @return |
||
| 57 | +170 |
- #' df = adlb,+ #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`, |
||
| 58 | +171 |
- #' xvar = "AVISIT",+ #' `n`, `hr`, `lcl`, `ucl`, and `pval`. |
||
| 59 | +172 |
- #' yvar = "AVAL",+ #' |
||
| 60 | +173 |
- #' xlab = "Visit",+ #' @examples |
||
| 61 | +174 |
- #' id_var = "USUBJID",+ #' library(survival) |
||
| 62 | +175 |
- #' ylab = "SGOT/ALT (U/L)",+ #' |
||
| 63 | +176 |
- #' add_baseline_hline = TRUE+ #' dta_simple <- data.frame( |
||
| 64 | +177 |
- #' )+ #' time = c(5, 5, 10, 10, 5, 5, 10, 10), |
||
| 65 | +178 |
- #' p+ #' status = c(0, 0, 1, 0, 0, 1, 1, 1), |
||
| 66 | +179 |
- #'+ #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
|
||
| 67 | +180 |
- #' @export+ #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75), |
||
| 68 | +181 |
- h_g_ipp <- function(df,+ #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
|
||
| 69 | +182 |
- xvar,+ #' ) |
||
| 70 | +183 |
- yvar,+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple) |
||
| 71 | +184 |
- xlab,+ #' result <- h_coxreg_univar_extract( |
||
| 72 | +185 |
- ylab,+ #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple |
||
| 73 | +186 |
- id_var,+ #' ) |
||
| 74 | +187 |
- title = "Individual Patient Plots",+ #' result |
||
| 75 | +188 |
- subtitle = "",+ #' |
||
| 76 | +189 |
- caption = NULL,+ #' @export |
||
| 77 | +190 |
- add_baseline_hline = FALSE,+ h_coxreg_univar_extract <- function(effect, |
||
| 78 | +191 |
- yvar_baseline = "BASE",+ covar, |
||
| 79 | +192 |
- ggtheme = nestcolor::theme_nest(),+ data, |
||
| 80 | +193 |
- col = NULL) {
+ mod, |
||
| 81 | -13x | +|||
| 194 | +
- checkmate::assert_string(xvar)+ control = control_coxreg()) {
|
|||
| 82 | -13x | +195 | +66x |
- checkmate::assert_string(yvar)+ checkmate::assert_string(covar) |
| 83 | -13x | +196 | +66x |
- checkmate::assert_string(yvar_baseline)+ checkmate::assert_string(effect) |
| 84 | -13x | +197 | +66x |
- checkmate::assert_string(id_var)+ checkmate::assert_class(mod, "coxph") |
| 85 | -13x | +198 | +66x |
- checkmate::assert_string(xlab)+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
| 86 | -13x | +|||
| 199 | +
- checkmate::assert_string(ylab)+ |
|||
| 87 | -13x | +200 | +66x |
- checkmate::assert_string(title)+ mod_aov <- muffled_car_anova(mod, test_statistic) |
| 88 | -13x | +201 | +66x |
- checkmate::assert_string(subtitle)+ msum <- summary(mod, conf.int = control$conf_level) |
| 89 | -13x | +202 | +66x |
- checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df))+ sum_cox <- broom::tidy(msum)+ |
+
| 203 | ++ | + + | +||
| 204 | ++ |
+ # Combine results together. |
||
| 90 | -13x | +205 | +66x |
- checkmate::assert_data_frame(df)+ effect_aov <- mod_aov[effect, , drop = TRUE] |
| 91 | -13x | +206 | +66x |
- checkmate::assert_flag(add_baseline_hline)+ pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]] |
| 92 | -13x | +207 | +66x |
- checkmate::assert_character(col, null.ok = TRUE)+ sum_main <- sum_cox[grepl(effect, sum_cox$level), ] |
| 93 | +208 | |||
| 94 | -13x | +209 | +66x |
- p <- ggplot2::ggplot(+ term_label <- if (effect == covar) {
|
| 95 | -13x | +210 | +34x |
- data = df,+ paste0( |
| 96 | -13x | +211 | +34x |
- mapping = ggplot2::aes(+ levels(data[[covar]])[2], |
| 97 | -13x | +212 | +34x |
- x = .data[[xvar]],+ " vs control (",
|
| 98 | -13x | +213 | +34x |
- y = .data[[yvar]],+ levels(data[[covar]])[1], |
| 99 | -13x | +|||
| 214 | +
- group = .data[[id_var]],+ ")" |
|||
| 100 | -13x | +|||
| 215 | +
- colour = .data[[id_var]]+ ) |
|||
| 101 | +216 |
- )+ } else {
+ |
+ ||
| 217 | +32x | +
+ unname(labels_or_names(data[covar])) |
||
| 102 | +218 |
- ) ++ } |
||
| 103 | -13x | +219 | +66x |
- ggplot2::geom_line(linewidth = 0.4) ++ data.frame( |
| 104 | -13x | +220 | +66x |
- ggplot2::geom_point(size = 2) ++ effect = ifelse(covar == effect, "Treatment:", "Covariate:"), |
| 105 | -13x | +221 | +66x |
- ggplot2::labs(+ term = covar, |
| 106 | -13x | +222 | +66x |
- x = xlab,+ term_label = term_label, |
| 107 | -13x | +223 | +66x |
- y = ylab,+ level = levels(data[[effect]])[2], |
| 108 | -13x | +224 | +66x |
- title = title,+ n = mod[["n"]], |
| 109 | -13x | +225 | +66x |
- subtitle = subtitle,+ hr = unname(sum_main["exp(coef)"]), |
| 110 | -13x | +226 | +66x |
- caption = caption+ lcl = unname(sum_main[grep("lower", names(sum_main))]),
+ |
+
| 227 | +66x | +
+ ucl = unname(sum_main[grep("upper", names(sum_main))]),
+ |
+ ||
| 228 | +66x | +
+ pval = pval,+ |
+ ||
| 229 | +66x | +
+ stringsAsFactors = FALSE |
||
| 111 | +230 |
- ) ++ ) |
||
| 112 | -13x | +|||
| 231 | +
- ggtheme+ } |
|||
| 113 | +232 | |||
| 114 | -13x | +|||
| 233 | +
- if (add_baseline_hline) {
+ #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help+ |
+ |||
| 234 | ++ |
+ #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable.+ |
+ ||
| 235 | ++ |
+ #'+ |
+ ||
| 236 | ++ |
+ #' @return+ |
+ ||
| 237 | ++ |
+ #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`,+ |
+ ||
| 238 | ++ |
+ #' `n`, `term`, and `term_label`.+ |
+ ||
| 239 | ++ |
+ #'+ |
+ ||
| 240 | ++ |
+ #' @examples+ |
+ ||
| 241 | ++ |
+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ |
+ ||
| 242 | ++ |
+ #' result <- h_coxreg_multivar_extract(+ |
+ ||
| 243 | ++ |
+ #' var = "var1", mod = mod, data = dta_simple+ |
+ ||
| 244 | ++ |
+ #' )+ |
+ ||
| 245 | ++ |
+ #' result+ |
+ ||
| 246 | ++ |
+ #'+ |
+ ||
| 247 | ++ |
+ #' @export+ |
+ ||
| 248 | ++ |
+ h_coxreg_multivar_extract <- function(var,+ |
+ ||
| 249 | ++ |
+ data,+ |
+ ||
| 250 | ++ |
+ mod,+ |
+ ||
| 251 | ++ |
+ control = control_coxreg()) {
|
||
| 115 | -12x | +252 | +132x |
- baseline_df <- df[, c(id_var, yvar_baseline)]+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
| 116 | -12x | +253 | +132x |
- baseline_df <- unique(baseline_df)+ mod_aov <- muffled_car_anova(mod, test_statistic) |
| 117 | +254 | |||
| 118 | -12x | +255 | +132x |
- p <- p ++ msum <- summary(mod, conf.int = control$conf_level) |
| 119 | -12x | +256 | +132x |
- ggplot2::geom_hline(+ sum_anova <- broom::tidy(mod_aov) |
| 120 | -12x | +257 | +132x |
- data = baseline_df,+ sum_cox <- broom::tidy(msum) |
| 121 | -12x | +|||
| 258 | +
- mapping = ggplot2::aes(+ |
|||
| 122 | -12x | +259 | +132x |
- yintercept = .data[[yvar_baseline]],+ ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
|
| 123 | -12x | +260 | +132x |
- colour = .data[[id_var]]+ names(ret_anova)[2] <- "pval" |
| 124 | -+ | |||
| 261 | +132x |
- ),+ if (is.factor(data[[var]])) {
|
||
| 125 | -12x | +262 | +53x |
- linetype = "dotdash",+ ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ |
+
| 263 | ++ |
+ } else {
|
||
| 126 | -12x | +264 | +79x |
- linewidth = 0.4+ ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")] |
| 127 | +265 |
- ) ++ } |
||
| 128 | -12x | +266 | +132x |
- ggplot2::geom_text(+ names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
|
| 129 | -12x | +267 | +132x |
- data = baseline_df,+ varlab <- unname(labels_or_names(data[var])) |
| 130 | -12x | +268 | +132x |
- mapping = ggplot2::aes(+ ret_cox$term <- varlab+ |
+
| 269 | ++ | + | ||
| 131 | -12x | +270 | +132x |
- x = 1,+ if (is.numeric(data[[var]])) {
|
| 132 | -12x | +271 | +79x |
- y = .data[[yvar_baseline]],+ ret <- ret_cox |
| 133 | -12x | +272 | +79x |
- label = .data[[id_var]],+ ret$term_label <- ret$term |
| 134 | -12x | +273 | +53x |
- colour = .data[[id_var]]+ } else if (length(levels(data[[var]])) <= 2) {
|
| 135 | -+ | |||
| 274 | +34x |
- ),+ ret_anova$pval <- NA |
||
| 136 | -12x | +275 | +34x |
- nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)),+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")") |
| 137 | -12x | +276 | +34x |
- vjust = "right",+ ret_cox$level <- gsub(var, "", ret_cox$level) |
| 138 | -12x | +277 | +34x |
- size = 2+ ret_cox$term_label <- ret_cox$level |
| 139 | -+ | |||
| 278 | +34x |
- )+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
||
| 140 | +279 |
-
+ } else {
|
||
| 141 | -12x | +280 | +19x |
- if (!is.null(col)) {
+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")") |
| 142 | -1x | +281 | +19x |
- p <- p ++ ret_cox$level <- gsub(var, "", ret_cox$level) |
| 143 | -1x | +282 | +19x |
- ggplot2::scale_color_manual(values = col)+ ret_cox$term_label <- ret_cox$level+ |
+
| 283 | +19x | +
+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
||
| 144 | +284 |
- }+ } |
||
| 145 | +285 |
- }+ |
||
| 146 | -13x | +286 | +132x |
- p+ as.data.frame(ret) |
| 147 | +287 |
} |
| 148 | +1 |
-
+ #' Add titles, footnotes, page Number, and a bounding box to a grid grob |
|
| 149 | +2 |
- #' @describeIn g_ipp Plotting function for individual patient plots which, depending on user+ #' |
|
| 150 | +3 |
- #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter+ #' @description `r lifecycle::badge("stable")`
|
|
| 151 | +4 |
- #' values over time.+ #' |
|
| 152 | +5 |
- #'+ #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots) |
|
| 153 | +6 |
- #' @return A `ggplot` object or a list of `ggplot` objects.+ #' with title, footnote, and page numbers. |
|
| 154 | +7 |
#' |
|
| 155 | +8 |
- #' @examples+ #' @inheritParams grid::grob |
|
| 156 | +9 |
- #' library(dplyr)+ #' @param grob (`grob`)\cr a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown. |
|
| 157 | +10 |
- #'+ #' @param titles (`character`)\cr titles given as a vector of strings that are each separated by a newline and wrapped |
|
| 158 | +11 |
- #' # Select a small sample of data to plot.+ #' according to the page width. |
|
| 159 | +12 |
- #' adlb <- tern_ex_adlb %>%+ #' @param footnotes (`character`)\cr footnotes. Uses the same formatting rules as `titles`. |
|
| 160 | +13 |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ #' @param page (`string` or `NULL`)\cr page numeration. If `NULL` then no page number is displayed. |
|
| 161 | +14 |
- #' slice(1:36)+ #' @param width_titles (`grid::unit`)\cr width of titles. Usually defined as all the available space |
|
| 162 | +15 |
- #'+ #' `grid::unit(1, "npc")`, it is affected by the parameter `outer_margins`. Right margins (`outer_margins[4]`) |
|
| 163 | +16 |
- #' plot_list <- g_ipp(+ #' need to be subtracted to the allowed width. |
|
| 164 | +17 |
- #' df = adlb,+ #' @param width_footnotes (`grid::unit`)\cr width of footnotes. Same default and margin correction as `width_titles`. |
|
| 165 | +18 |
- #' xvar = "AVISIT",+ #' @param border (`flag`)\cr whether a border should be drawn around the plot or not. |
|
| 166 | +19 |
- #' yvar = "AVAL",+ #' @param padding (`grid::unit`)\cr padding. A unit object of length 4. Innermost margin between the plot (`grob`) |
|
| 167 | +20 |
- #' xlab = "Visit",+ #' and, possibly, the border of the plot. Usually expressed in 4 identical values (usually `"lines"`). It defaults |
|
| 168 | +21 |
- #' ylab = "SGOT/ALT (U/L)",+ #' to `grid::unit(rep(1, 4), "lines")`. |
|
| 169 | +22 |
- #' title = "Individual Patient Plots",+ #' @param margins (`grid::unit`)\cr margins. A unit object of length 4. Margins between the plot and the other |
|
| 170 | +23 |
- #' add_baseline_hline = TRUE,+ #' elements in the list (e.g. titles, plot, and footers). This is usually expressed in 4 `"lines"`, where the |
|
| 171 | +24 |
- #' plotting_choices = "split_by_max_obs",+ #' lateral ones are 0s, while top and bottom are 1s. It defaults to `grid::unit(c(1, 0, 1, 0), "lines")`. |
|
| 172 | +25 |
- #' max_obs_per_plot = 5+ #' @param outer_margins (`grid::unit`)\cr outer margins. A unit object of length 4. It defines the general margin of |
|
| 173 | +26 |
- #' )+ #' the plot, considering also decorations like titles, footnotes, and page numbers. It defaults to |
|
| 174 | +27 |
- #' plot_list+ #' `grid::unit(c(2, 1.5, 3, 1.5), "cm")`. |
|
| 175 | +28 |
- #'+ #' @param gp_titles (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`. |
|
| 176 | +29 |
- #' @export+ #' @param gp_footnotes (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`. |
|
| 177 | +30 |
- g_ipp <- function(df,+ #' |
|
| 178 | +31 |
- xvar,+ #' @return A grid grob (`gTree`). |
|
| 179 | +32 |
- yvar,+ #' |
|
| 180 | +33 |
- xlab,+ #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually. |
|
| 181 | +34 |
- ylab,+ #' |
|
| 182 | +35 |
- id_var = "USUBJID",+ #' @examples |
|
| 183 | +36 |
- title = "Individual Patient Plots",+ #' library(grid) |
|
| 184 | +37 |
- subtitle = "",+ #' |
|
| 185 | +38 |
- caption = NULL,+ #' titles <- c( |
|
| 186 | +39 |
- add_baseline_hline = FALSE,+ #' "Edgar Anderson's Iris Data", |
|
| 187 | +40 |
- yvar_baseline = "BASE",+ #' paste( |
|
| 188 | +41 |
- ggtheme = nestcolor::theme_nest(),+ #' "This famous (Fisher's or Anderson's) iris data set gives the measurements", |
|
| 189 | +42 |
- plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
+ #' "in centimeters of the variables sepal length and width and petal length", |
|
| 190 | +43 |
- max_obs_per_plot = 4,+ #' "and width, respectively, for 50 flowers from each of 3 species of iris." |
|
| 191 | +44 |
- col = NULL) {
+ #' ) |
|
| 192 | -3x | +||
| 45 | +
- checkmate::assert_count(max_obs_per_plot)+ #' ) |
||
| 193 | -3x | +||
| 46 | +
- checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
+ #' |
||
| 194 | -3x | +||
| 47 | +
- checkmate::assert_character(col, null.ok = TRUE)+ #' footnotes <- c( |
||
| 195 | +48 |
-
+ #' "The species are Iris setosa, versicolor, and virginica.", |
|
| 196 | -3x | +||
| 49 | +
- plotting_choices <- match.arg(plotting_choices)+ #' paste( |
||
| 197 | +50 |
-
+ #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named", |
|
| 198 | -3x | +||
| 51 | +
- if (plotting_choices == "all_in_one") {
+ #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species." |
||
| 199 | -1x | +||
| 52 | +
- p <- h_g_ipp(+ #' ) |
||
| 200 | -1x | +||
| 53 | +
- df = df,+ #' ) |
||
| 201 | -1x | +||
| 54 | +
- xvar = xvar,+ #' |
||
| 202 | -1x | +||
| 55 | +
- yvar = yvar,+ #' ## empty plot |
||
| 203 | -1x | +||
| 56 | +
- xlab = xlab,+ #' grid.newpage() |
||
| 204 | -1x | +||
| 57 | +
- ylab = ylab,+ #' |
||
| 205 | -1x | +||
| 58 | +
- id_var = id_var,+ #' grid.draw( |
||
| 206 | -1x | +||
| 59 | +
- title = title,+ #' decorate_grob( |
||
| 207 | -1x | +||
| 60 | +
- subtitle = subtitle,+ #' NULL, |
||
| 208 | -1x | +||
| 61 | +
- caption = caption,+ #' titles = titles, |
||
| 209 | -1x | +||
| 62 | +
- add_baseline_hline = add_baseline_hline,+ #' footnotes = footnotes, |
||
| 210 | -1x | +||
| 63 | +
- yvar_baseline = yvar_baseline,+ #' page = "Page 4 of 10" |
||
| 211 | -1x | +||
| 64 | +
- ggtheme = ggtheme,+ #' ) |
||
| 212 | -1x | +||
| 65 | +
- col = col+ #' ) |
||
| 213 | +66 |
- )+ #' |
|
| 214 | +67 |
-
+ #' # grid |
|
| 215 | -1x | +||
| 68 | +
- return(p)+ #' p <- gTree( |
||
| 216 | -2x | +||
| 69 | +
- } else if (plotting_choices == "split_by_max_obs") {
+ #' children = gList( |
||
| 217 | -1x | +||
| 70 | +
- id_vec <- unique(df[[id_var]])+ #' rectGrob(), |
||
| 218 | -1x | +||
| 71 | +
- id_list <- split(+ #' xaxisGrob(), |
||
| 219 | -1x | +||
| 72 | +
- id_vec,+ #' yaxisGrob(), |
||
| 220 | -1x | +||
| 73 | +
- rep(1:ceiling(length(id_vec) / max_obs_per_plot),+ #' textGrob("Sepal.Length", y = unit(-4, "lines")),
|
||
| 221 | -1x | +||
| 74 | +
- each = max_obs_per_plot,+ #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
|
||
| 222 | -1x | +||
| 75 | +
- length.out = length(id_vec)+ #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16) |
||
| 223 | +76 |
- )+ #' ), |
|
| 224 | +77 |
- )+ #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length)) |
|
| 225 | +78 |
-
+ #' ) |
|
| 226 | -1x | +||
| 79 | +
- df_list <- list()+ #' grid.newpage() |
||
| 227 | -1x | +||
| 80 | +
- plot_list <- list()+ #' grid.draw(p) |
||
| 228 | +81 |
-
+ #' |
|
| 229 | -1x | +||
| 82 | +
- for (i in seq_along(id_list)) {
+ #' grid.newpage() |
||
| 230 | -2x | +||
| 83 | +
- df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ]+ #' grid.draw( |
||
| 231 | +84 |
-
+ #' decorate_grob( |
|
| 232 | -2x | +||
| 85 | +
- plots <- h_g_ipp(+ #' grob = p, |
||
| 233 | -2x | +||
| 86 | +
- df = df_list[[i]],- |
- ||
| 234 | -2x | -
- xvar = xvar,- |
- |
| 235 | -2x | -
- yvar = yvar,- |
- |
| 236 | -2x | -
- xlab = xlab,- |
- |
| 237 | -2x | -
- ylab = ylab,- |
- |
| 238 | -2x | -
- id_var = id_var,- |
- |
| 239 | -2x | -
- title = title,- |
- |
| 240 | -2x | -
- subtitle = subtitle,- |
- |
| 241 | -2x | -
- caption = caption,- |
- |
| 242 | -2x | -
- add_baseline_hline = add_baseline_hline,- |
- |
| 243 | -2x | -
- yvar_baseline = yvar_baseline,- |
- |
| 244 | -2x | -
- ggtheme = ggtheme,- |
- |
| 245 | -2x | -
- col = col+ #' titles = titles, |
|
| 246 | +87 |
- )+ #' footnotes = footnotes, |
|
| 247 | +88 | - - | -|
| 248 | -2x | -
- plot_list[[i]] <- plots+ #' page = "Page 6 of 129" |
|
| 249 | +89 |
- }- |
- |
| 250 | -1x | -
- return(plot_list)+ #' ) |
|
| 251 | +90 |
- } else {
- |
- |
| 252 | -1x | -
- ind_df <- split(df, df[[id_var]])- |
- |
| 253 | -1x | -
- plot_list <- lapply(- |
- |
| 254 | -1x | -
- ind_df,- |
- |
| 255 | -1x | -
- function(x) {
- |
- |
| 256 | -8x | -
- h_g_ipp(- |
- |
| 257 | -8x | -
- df = x,- |
- |
| 258 | -8x | -
- xvar = xvar,- |
- |
| 259 | -8x | -
- yvar = yvar,- |
- |
| 260 | -8x | -
- xlab = xlab,- |
- |
| 261 | -8x | -
- ylab = ylab,- |
- |
| 262 | -8x | -
- id_var = id_var,- |
- |
| 263 | -8x | -
- title = title,- |
- |
| 264 | -8x | -
- subtitle = subtitle,- |
- |
| 265 | -8x | -
- caption = caption,- |
- |
| 266 | -8x | -
- add_baseline_hline = add_baseline_hline,- |
- |
| 267 | -8x | -
- yvar_baseline = yvar_baseline,- |
- |
| 268 | -8x | -
- ggtheme = ggtheme,- |
- |
| 269 | -8x | -
- col = col+ #' ) |
|
| 270 | +91 |
- )+ #' |
|
| 271 | +92 |
- }+ #' ## with ggplot2 |
|
| 272 | +93 |
- )+ #' library(ggplot2) |
|
| 273 | +94 |
-
+ #' |
|
| 274 | -1x | +||
| 95 | +
- return(plot_list)+ #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 275 | +96 |
- }+ #' ggplot2::geom_point() |
|
| 276 | +97 |
- }+ #' p_gg |
| 1 | +98 |
- #' Tabulate biomarker effects on survival by subgroup+ #' p <- ggplotGrob(p_gg) |
||
| 2 | +99 |
- #'+ #' grid.newpage() |
||
| 3 | +100 |
- #' @description `r lifecycle::badge("stable")`
+ #' grid.draw( |
||
| 4 | +101 |
- #'+ #' decorate_grob( |
||
| 5 | +102 |
- #' The [tabulate_survival_biomarkers()] function creates a layout element to tabulate the estimated effects of multiple+ #' grob = p, |
||
| 6 | +103 |
- #' continuous biomarker variables on survival across subgroups, returning statistics including median survival time and+ #' titles = titles, |
||
| 7 | +104 |
- #' hazard ratio for each population subgroup. The table is created from `df`, a list of data frames returned by+ #' footnotes = footnotes, |
||
| 8 | +105 |
- #' [extract_survival_biomarkers()], with the statistics to include specified via the `vars` parameter.+ #' page = "Page 6 of 129" |
||
| 9 | +106 |
- #'+ #' ) |
||
| 10 | +107 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ #' ) |
||
| 11 | +108 |
#' |
||
| 12 | +109 |
- #' @inheritParams fit_coxreg_multivar+ #' ## with lattice |
||
| 13 | +110 |
- #' @inheritParams survival_duration_subgroups+ #' library(lattice) |
||
| 14 | +111 |
- #' @inheritParams argument_convention+ #' |
||
| 15 | +112 |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species) |
||
| 16 | +113 |
- #' [extract_survival_biomarkers()].+ #' p <- grid.grab() |
||
| 17 | +114 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' grid.newpage() |
||
| 18 | +115 |
- #' * `n_tot_events`: Total number of events per group.+ #' grid.draw( |
||
| 19 | +116 |
- #' * `n_tot`: Total number of observations per group.+ #' decorate_grob( |
||
| 20 | +117 |
- #' * `median`: Median survival time.+ #' grob = p, |
||
| 21 | +118 |
- #' * `hr`: Hazard ratio.+ #' titles = titles, |
||
| 22 | +119 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' footnotes = footnotes, |
||
| 23 | +120 |
- #' * `pval`: p-value of the effect.+ #' page = "Page 6 of 129" |
||
| 24 | +121 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required.+ #' ) |
||
| 25 | +122 |
- #'+ #' ) |
||
| 26 | +123 |
- #' @details These functions create a layout starting from a data frame which contains+ #' |
||
| 27 | +124 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ #' # with gridExtra - no borders |
||
| 28 | +125 |
- #'+ #' library(gridExtra) |
||
| 29 | +126 |
- #' @examples+ #' grid.newpage() |
||
| 30 | +127 |
- #' library(dplyr)+ #' grid.draw( |
||
| 31 | +128 |
- #'+ #' decorate_grob( |
||
| 32 | +129 |
- #' adtte <- tern_ex_adtte+ #' tableGrob( |
||
| 33 | +130 |
- #'+ #' head(mtcars) |
||
| 34 | +131 |
- #' # Save variable labels before data processing steps.+ #' ), |
||
| 35 | +132 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' titles = "title", |
||
| 36 | +133 |
- #'+ #' footnotes = "footnote", |
||
| 37 | +134 |
- #' adtte_f <- adtte %>%+ #' border = FALSE |
||
| 38 | +135 |
- #' filter(PARAMCD == "OS") %>%+ #' ) |
||
| 39 | +136 |
- #' mutate(+ #' ) |
||
| 40 | +137 |
- #' AVALU = as.character(AVALU),+ #' |
||
| 41 | +138 |
- #' is_event = CNSR == 0+ #' @export |
||
| 42 | +139 |
- #' )+ decorate_grob <- function(grob, |
||
| 43 | +140 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ titles, |
||
| 44 | +141 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ footnotes, |
||
| 45 | +142 |
- #'+ page = "", |
||
| 46 | +143 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ width_titles = grid::unit(1, "npc"), |
||
| 47 | +144 |
- #' # in multiple regression models containing one covariate `RACE`,+ width_footnotes = grid::unit(1, "npc"), |
||
| 48 | +145 |
- #' # as well as one stratification variable `STRATA1`. The subgroups+ border = TRUE, |
||
| 49 | +146 |
- #' # are defined by the levels of `BMRKR2`.+ padding = grid::unit(rep(1, 4), "lines"), |
||
| 50 | +147 |
- #'+ margins = grid::unit(c(1, 0, 1, 0), "lines"), |
||
| 51 | +148 |
- #' df <- extract_survival_biomarkers(+ outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"), |
||
| 52 | +149 |
- #' variables = list(+ gp_titles = grid::gpar(), |
||
| 53 | +150 |
- #' tte = "AVAL",+ gp_footnotes = grid::gpar(fontsize = 8), |
||
| 54 | +151 |
- #' is_event = "is_event",+ name = NULL, |
||
| 55 | +152 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ gp = grid::gpar(), |
||
| 56 | +153 |
- #' strata = "STRATA1",+ vp = NULL) {
|
||
| 57 | +154 |
- #' covariates = "SEX",+ # External margins need to be taken into account when defining the width of titles and footers |
||
| 58 | +155 |
- #' subgroups = "BMRKR2"+ # because the text is split in advance depending on only the width of the viewport. |
||
| 59 | -+ | |||
| 156 | +9x |
- #' ),+ if (any(as.numeric(outer_margins) > 0)) {
|
||
| 60 | -+ | |||
| 157 | +9x |
- #' label_all = "Total Patients",+ width_titles <- width_titles - outer_margins[4] |
||
| 61 | -+ | |||
| 158 | +9x |
- #' data = adtte_f+ width_footnotes <- width_footnotes - outer_margins[4] |
||
| 62 | +159 |
- #' )+ } |
||
| 63 | +160 |
- #' df+ |
||
| 64 | -+ | |||
| 161 | +9x |
- #'+ st_titles <- split_text_grob( |
||
| 65 | -+ | |||
| 162 | +9x |
- #' # Here we group the levels of `BMRKR2` manually.+ titles, |
||
| 66 | -+ | |||
| 163 | +9x |
- #' df_grouped <- extract_survival_biomarkers(+ x = 0, y = 1, |
||
| 67 | -+ | |||
| 164 | +9x |
- #' variables = list(+ just = c("left", "top"),
|
||
| 68 | -+ | |||
| 165 | +9x |
- #' tte = "AVAL",+ width = width_titles, |
||
| 69 | -+ | |||
| 166 | +9x |
- #' is_event = "is_event",+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1), |
||
| 70 | -+ | |||
| 167 | +9x |
- #' biomarkers = c("BMRKR1", "AGE"),
+ gp = gp_titles |
||
| 71 | +168 |
- #' strata = "STRATA1",+ ) |
||
| 72 | +169 |
- #' covariates = "SEX",+ |
||
| 73 | -+ | |||
| 170 | +9x |
- #' subgroups = "BMRKR2"+ st_footnotes <- split_text_grob( |
||
| 74 | -+ | |||
| 171 | +9x |
- #' ),+ footnotes, |
||
| 75 | -+ | |||
| 172 | +9x |
- #' data = adtte_f,+ x = 0, y = 1, |
||
| 76 | -+ | |||
| 173 | +9x |
- #' groups_lists = list(+ just = c("left", "top"),
|
||
| 77 | -+ | |||
| 174 | +9x |
- #' BMRKR2 = list(+ width = width_footnotes, |
||
| 78 | -+ | |||
| 175 | +9x |
- #' "low" = "LOW",+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1), |
||
| 79 | -+ | |||
| 176 | +9x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ gp = gp_footnotes |
||
| 80 | +177 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ ) |
||
| 81 | +178 |
- #' )+ |
||
| 82 | -+ | |||
| 179 | +9x |
- #' )+ pg_footnote <- grid::textGrob( |
||
| 83 | -+ | |||
| 180 | +9x |
- #' )+ paste("\n", page),
|
||
| 84 | -+ | |||
| 181 | +9x |
- #' df_grouped+ x = 1, y = 0, |
||
| 85 | -+ | |||
| 182 | +9x |
- #'+ just = c("right", "bottom"),
|
||
| 86 | -+ | |||
| 183 | +9x |
- #' @name survival_biomarkers_subgroups+ vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1), |
||
| 87 | -+ | |||
| 184 | +9x |
- #' @order 1+ gp = gp_footnotes |
||
| 88 | +185 |
- NULL+ ) |
||
| 89 | +186 | |||
| 90 | +187 |
- #' Prepare survival data estimates for multiple biomarkers in a single data frame+ # Initial decoration of the grob -> border, paddings, and margins are used here |
||
| 91 | -+ | |||
| 188 | +9x |
- #'+ main_plot <- grid::gTree( |
||
| 92 | -+ | |||
| 189 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ children = grid::gList( |
||
| 93 | -+ | |||
| 190 | +9x |
- #'+ if (border) grid::rectGrob(), |
||
| 94 | -+ | |||
| 191 | +9x |
- #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates,+ grid::gTree( |
||
| 95 | -+ | |||
| 192 | +9x |
- #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame.+ children = grid::gList( |
||
| 96 | -+ | |||
| 193 | +9x |
- #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements+ grob |
||
| 97 | +194 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strata`.+ ), |
||
| 98 | -+ | |||
| 195 | +9x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ vp = grid::plotViewport(margins = padding) # innermost margins of the grob plot |
||
| 99 | +196 |
- #'+ ) |
||
| 100 | +197 |
- #' @inheritParams argument_convention+ ), |
||
| 101 | -+ | |||
| 198 | +9x |
- #' @inheritParams fit_coxreg_multivar+ vp = grid::vpStack( |
||
| 102 | -+ | |||
| 199 | +9x |
- #' @inheritParams survival_duration_subgroups+ grid::viewport(layout.pos.row = 2, layout.pos.col = 1), |
||
| 103 | -+ | |||
| 200 | +9x |
- #'+ grid::plotViewport(margins = margins) # margins around the border plot |
||
| 104 | +201 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`,+ ) |
||
| 105 | +202 |
- #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ ) |
||
| 106 | +203 |
- #' `var_label`, and `row_type`.+ |
||
| 107 | -+ | |||
| 204 | +9x |
- #'+ grid::gTree( |
||
| 108 | -+ | |||
| 205 | +9x |
- #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()].+ grob = grob, |
||
| 109 | -+ | |||
| 206 | +9x |
- #'+ titles = titles, |
||
| 110 | -+ | |||
| 207 | +9x |
- #' @export+ footnotes = footnotes, |
||
| 111 | -+ | |||
| 208 | +9x |
- extract_survival_biomarkers <- function(variables,+ page = page, |
||
| 112 | -+ | |||
| 209 | +9x |
- data,+ width_titles = width_titles, |
||
| 113 | -+ | |||
| 210 | +9x |
- groups_lists = list(),+ width_footnotes = width_footnotes, |
||
| 114 | -+ | |||
| 211 | +9x |
- control = control_coxreg(),+ outer_margins = outer_margins, |
||
| 115 | -+ | |||
| 212 | +9x |
- label_all = "All Patients") {
+ gp_titles = gp_titles, |
||
| 116 | -6x | +213 | +9x |
- if ("strat" %in% names(variables)) {
+ gp_footnotes = gp_footnotes, |
| 117 | -! | +|||
| 214 | +9x |
- warning(+ children = grid::gList( |
||
| 118 | -! | +|||
| 215 | +9x |
- "Warning: the `strat` element name of the `variables` list argument to `extract_survival_biomarkers() ",+ grid::gTree( |
||
| 119 | -! | +|||
| 216 | +9x |
- "was deprecated in tern 0.9.4.\n ",+ children = grid::gList( |
||
| 120 | -! | +|||
| 217 | +9x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ st_titles, |
||
| 121 | -+ | |||
| 218 | +9x |
- )+ main_plot, # main plot with border, padding, and margins |
||
| 122 | -! | +|||
| 219 | +9x |
- variables[["strata"]] <- variables[["strat"]]+ st_footnotes, |
||
| 123 | -+ | |||
| 220 | +9x |
- }+ pg_footnote |
||
| 124 | +221 |
-
+ ), |
||
| 125 | -6x | +222 | +9x |
- checkmate::assert_list(variables)+ childrenvp = NULL, |
| 126 | -6x | +223 | +9x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ name = "titles_grob_footnotes", |
| 127 | -6x | +224 | +9x |
- checkmate::assert_string(label_all)+ vp = grid::vpStack( |
| 128 | -+ | |||
| 225 | +9x |
-
+ grid::plotViewport(margins = outer_margins), # Main external margins |
||
| 129 | -+ | |||
| 226 | +9x |
- # Start with all patients.+ grid::viewport( |
||
| 130 | -6x | +227 | +9x |
- result_all <- h_coxreg_mult_cont_df(+ layout = grid::grid.layout( |
| 131 | -6x | +228 | +9x |
- variables = variables,+ nrow = 4, ncol = 1, |
| 132 | -6x | +229 | +9x |
- data = data,+ heights = grid::unit.c( |
| 133 | -6x | +230 | +9x |
- control = control- |
-
| 134 | -- |
- )+ grid::grobHeight(st_titles), |
||
| 135 | -6x | +231 | +9x |
- result_all$subgroup <- label_all+ grid::unit(1, "null"), |
| 136 | -6x | +232 | +9x |
- result_all$var <- "ALL"+ grid::grobHeight(st_footnotes), |
| 137 | -6x | +233 | +9x |
- result_all$var_label <- label_all+ grid::grobHeight(pg_footnote) |
| 138 | -6x | +|||
| 234 | +
- result_all$row_type <- "content"+ ) |
|||
| 139 | -6x | +|||
| 235 | +
- if (is.null(variables$subgroups)) {
+ ) |
|||
| 140 | +236 |
- # Only return result for all patients.+ ) |
||
| 141 | -1x | +|||
| 237 | +
- result_all+ ) |
|||
| 142 | +238 |
- } else {
+ ) |
||
| 143 | +239 |
- # Add subgroups results.+ ), |
||
| 144 | -5x | +240 | +9x |
- l_data <- h_split_by_subgroups(+ name = name, |
| 145 | -5x | +241 | +9x |
- data,+ gp = gp, |
| 146 | -5x | +242 | +9x |
- variables$subgroups,+ vp = vp, |
| 147 | -5x | +243 | +9x |
- groups_lists = groups_lists+ cl = "decoratedGrob" |
| 148 | +244 |
- )- |
- ||
| 149 | -5x | -
- l_result <- lapply(l_data, function(grp) {
+ ) |
||
| 150 | -25x | +|||
| 245 | +
- result <- h_coxreg_mult_cont_df(+ } |
|||
| 151 | -25x | +|||
| 246 | +
- variables = variables,+ |
|||
| 152 | -25x | +|||
| 247 | +
- data = grp$df,+ # nocov start |
|||
| 153 | -25x | +|||
| 248 | +
- control = control+ #' @importFrom grid validDetails |
|||
| 154 | +249 |
- )+ #' @noRd |
||
| 155 | -25x | +|||
| 250 | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ validDetails.decoratedGrob <- function(x) {
|
|||
| 156 | -25x | +|||
| 251 | +
- cbind(result, result_labels)+ checkmate::assert_character(x$titles) |
|||
| 157 | +252 |
- })+ checkmate::assert_character(x$footnotes) |
||
| 158 | -5x | +|||
| 253 | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
|||
| 159 | -5x | +|||
| 254 | +
- result_subgroups$row_type <- "analysis"+ if (!is.null(x$grob)) {
|
|||
| 160 | -5x | +|||
| 255 | +
- rbind(+ checkmate::assert_true(grid::is.grob(x$grob)) |
|||
| 161 | -5x | +|||
| 256 | +
- result_all,+ } |
|||
| 162 | -5x | +|||
| 257 | +
- result_subgroups+ if (length(x$page) == 1) {
|
|||
| 163 | +258 |
- )+ checkmate::assert_character(x$page) |
||
| 164 | +259 |
} |
||
| 165 | +260 |
- }+ if (!grid::is.unit(x$outer_margins)) {
|
||
| 166 | +261 |
-
+ checkmate::assert_vector(x$outer_margins, len = 4) |
||
| 167 | +262 |
- #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table+ } |
||
| 168 | +263 |
- #' summarizing biomarker effects on survival by subgroup.+ if (!grid::is.unit(x$margins)) {
|
||
| 169 | +264 |
- #'+ checkmate::assert_vector(x$margins, len = 4) |
||
| 170 | +265 |
- #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
+ } |
||
| 171 | +266 |
- #' [extract_survival_biomarkers()] function when creating `df`.+ if (!grid::is.unit(x$padding)) {
|
||
| 172 | +267 |
- #'+ checkmate::assert_vector(x$padding, len = 4) |
||
| 173 | +268 |
- #' @return An `rtables` table summarizing biomarker effects on survival by subgroup.+ } |
||
| 174 | +269 |
- #'+ |
||
| 175 | +270 |
- #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does+ x |
||
| 176 | +271 |
- #' not start from an input layout `lyt`. This is because internally the table is+ } |
||
| 177 | +272 |
- #' created by combining multiple subtables.+ |
||
| 178 | +273 |
- #'+ #' @importFrom grid widthDetails |
||
| 179 | +274 |
- #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()].+ #' @noRd |
||
| 180 | +275 |
- #'+ widthDetails.decoratedGrob <- function(x) {
|
||
| 181 | +276 |
- #' @examples+ grid::unit(1, "null") |
||
| 182 | +277 |
- #' ## Table with default columns.+ } |
||
| 183 | +278 |
- #' tabulate_survival_biomarkers(df)+ |
||
| 184 | +279 |
- #'+ #' @importFrom grid heightDetails |
||
| 185 | +280 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ #' @noRd |
||
| 186 | +281 |
- #' tab <- tabulate_survival_biomarkers(+ heightDetails.decoratedGrob <- function(x) {
|
||
| 187 | +282 |
- #' df = df,+ grid::unit(1, "null") |
||
| 188 | +283 |
- #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
+ } |
||
| 189 | +284 |
- #' time_unit = as.character(adtte_f$AVALU[1])+ |
||
| 190 | +285 |
- #' )+ #' Split text according to available text width |
||
| 191 | +286 |
#' |
||
| 192 | +287 |
- #' ## Finally produce the forest plot.+ #' Dynamically wrap text. |
||
| 193 | +288 |
- #' \donttest{
+ #' |
||
| 194 | +289 |
- #' g_forest(tab, xlim = c(0.8, 1.2))+ #' @inheritParams grid::grid.text |
||
| 195 | +290 |
- #' }+ #' @param text (`string`)\cr the text to wrap. |
||
| 196 | +291 |
- #'+ #' @param width (`grid::unit`)\cr a unit object specifying maximum width of text. |
||
| 197 | +292 |
- #' @export+ #' |
||
| 198 | +293 |
- #' @order 2+ #' @return A text `grob`. |
||
| 199 | +294 |
- tabulate_survival_biomarkers <- function(df,+ #' |
||
| 200 | +295 |
- vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition` |
||
| 201 | +296 |
- groups_lists = list(),+ #' |
||
| 202 | +297 |
- control = control_coxreg(),+ #' @keywords internal |
||
| 203 | +298 |
- label_all = lifecycle::deprecated(),+ split_text_grob <- function(text, |
||
| 204 | +299 |
- time_unit = NULL,+ x = grid::unit(0.5, "npc"), |
||
| 205 | +300 |
- na_str = default_na_str(),+ y = grid::unit(0.5, "npc"), |
||
| 206 | +301 |
- .indent_mods = 0L) {
- |
- ||
| 207 | -5x | -
- if (lifecycle::is_present(label_all)) {
+ width = grid::unit(1, "npc"), |
||
| 208 | -1x | +|||
| 302 | +
- lifecycle::deprecate_warn(+ just = "centre", |
|||
| 209 | -1x | +|||
| 303 | +
- "0.9.5", "tabulate_survival_biomarkers(label_all)",+ hjust = NULL, |
|||
| 210 | -1x | +|||
| 304 | +
- details = paste(+ vjust = NULL, |
|||
| 211 | -1x | +|||
| 305 | +
- "Please assign the `label_all` parameter within the",+ default.units = "npc", # nolint |
|||
| 212 | -1x | +|||
| 306 | +
- "`extract_survival_biomarkers()` function when creating `df`."+ name = NULL, |
|||
| 213 | +307 |
- )+ gp = grid::gpar(), |
||
| 214 | +308 |
- )+ vp = NULL) {
|
||
| 215 | +309 |
- }+ text <- gsub("\\\\n", "\n", text) # fixing cases of mixed behavior (\n and \\n)
|
||
| 216 | +310 | |||
| 217 | -5x | +|||
| 311 | +
- checkmate::assert_data_frame(df)+ if (!grid::is.unit(x)) x <- grid::unit(x, default.units) |
|||
| 218 | -5x | +|||
| 312 | +
- checkmate::assert_character(df$biomarker)+ if (!grid::is.unit(y)) y <- grid::unit(y, default.units) |
|||
| 219 | -5x | +|||
| 313 | +
- checkmate::assert_character(df$biomarker_label)+ if (!grid::is.unit(width)) width <- grid::unit(width, default.units) |
|||
| 220 | -5x | +|||
| 314 | +
- checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
+ if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
|
|||
| 221 | +315 |
-
+ if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
|
||
| 222 | -5x | +|||
| 316 | +
- extra_args <- list(groups_lists = groups_lists, control = control)+ if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
|
|||
| 223 | +317 | |||
| 224 | -5x | -
- df_subs <- split(df, f = df$biomarker)- |
- ||
| 225 | -5x | +|||
| 318 | +
- tabs <- lapply(df_subs, FUN = function(df_sub) {
+ if (length(gp) > 0) { # account for effect of gp on text width -> it was bugging when text was empty
|
|||
| 226 | -9x | +|||
| 319 | +
- tab_sub <- h_tab_surv_one_biomarker(+ horizontal_npc_width_no_gp <- grid::convertWidth( |
|||
| 227 | -9x | +|||
| 320 | +
- df = df_sub,+ grid::grobWidth( |
|||
| 228 | -9x | +|||
| 321 | +
- vars = vars,+ grid::textGrob( |
|||
| 229 | -9x | +|||
| 322 | +
- time_unit = time_unit,+ paste0(text, collapse = "\n") |
|||
| 230 | -9x | +|||
| 323 | +
- na_str = na_str,+ ) |
|||
| 231 | -9x | +|||
| 324 | +
- .indent_mods = .indent_mods,+ ), "npc", |
|||
| 232 | -9x | +|||
| 325 | +
- extra_args = extra_args+ valueOnly = TRUE |
|||
| 233 | +326 |
) |
||
| 234 | +327 |
- # Insert label row as first row in table.- |
- ||
| 235 | -9x | -
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]- |
- ||
| 236 | -9x | -
- tab_sub+ horizontal_npc_width_with_gp <- grid::convertWidth(grid::grobWidth( |
||
| 237 | +328 |
- })+ grid::textGrob( |
||
| 238 | -5x | +|||
| 329 | +
- result <- do.call(rbind, tabs)+ paste0(text, collapse = "\n"), |
|||
| 239 | +330 |
-
+ gp = gp |
||
| 240 | -5x | +|||
| 331 | +
- n_tot_ids <- grep("^n_tot", vars)
+ ) |
|||
| 241 | -5x | +|||
| 332 | +
- hr_id <- match("hr", vars)
+ ), "npc", valueOnly = TRUE) |
|||
| 242 | -5x | +|||
| 333 | +
- ci_id <- match("ci", vars)
+
|
|||
| 243 | -5x | +|||
| 334 | +
- structure(+ # Adapting width to the input gpar (it is normalized so does not matter what is text) |
|||
| 244 | -5x | +|||
| 335 | +
- result,+ width <- width * horizontal_npc_width_no_gp / horizontal_npc_width_with_gp |
|||
| 245 | -5x | +|||
| 336 | +
- forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
+ } |
|||
| 246 | -5x | +|||
| 337 | +
- col_x = hr_id,+ |
|||
| 247 | -5x | +|||
| 338 | +
- col_ci = ci_id,+ ## if it is a fixed unit then we do not need to recalculate when viewport resized |
|||
| 248 | -5x | +|||
| 339 | +
- col_symbol_size = n_tot_ids[1]+ if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) && |
|||
| 249 | +340 |
- )+ attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
|
||
| 250 | +341 |
- }+ attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n") |
| 1 | +342 |
- #' Incidence rate estimation+ } |
||
| 2 | +343 |
- #'+ |
||
| 3 | +344 |
- #' @description `r lifecycle::badge("stable")`
+ # Fix for split_string in case of residual \n (otherwise is counted as character) |
||
| 4 | +345 |
- #'+ text2 <- unlist( |
||
| 5 | +346 |
- #' The analyze function [estimate_incidence_rate()] creates a layout element to estimate an event rate adjusted for+ strsplit( |
||
| 6 | +347 |
- #' person-years at risk, otherwise known as incidence rate. The primary analysis variable specified via `vars` is+ paste0(text, collapse = "\n"), # for "" cases |
||
| 7 | +348 |
- #' the person-years at risk. In addition to this variable, the `n_events` variable for number of events observed (where+ "\n" |
||
| 8 | +349 |
- #' a value of 1 means an event was observed and 0 means that no event was observed) must also be specified.+ ) |
||
| 9 | +350 |
- #'+ ) |
||
| 10 | +351 |
- #' @inheritParams argument_convention+ |
||
| 11 | +352 |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ # Final grid text with cat-friendly split_string |
||
| 12 | +353 |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ grid::grid.text( |
||
| 13 | +354 |
- #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.+ label = split_string(text2, width), |
||
| 14 | +355 |
- #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ x = x, y = y, |
||
| 15 | +356 |
- #' for confidence interval type.+ just = just, |
||
| 16 | +357 |
- #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default)+ hjust = hjust, |
||
| 17 | +358 |
- #' indicating time unit for data input.+ vjust = vjust, |
||
| 18 | +359 |
- #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years).+ rot = 0, |
||
| 19 | +360 |
- #' @param n_events (`string`)\cr name of integer variable indicating whether an event has been observed (1) or not (0).+ check.overlap = FALSE, |
||
| 20 | +361 |
- #' @param id_var (`string`)\cr name of variable used as patient identifier if `"n_unique"` is included in `.stats`.+ name = name, |
||
| 21 | +362 |
- #' Defaults to `"USUBJID"`.+ gp = gp, |
||
| 22 | +363 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ vp = vp, |
||
| 23 | +364 |
- #'+ draw = FALSE |
||
| 24 | +365 |
- #' Options are: ``r shQuote(get_stats("estimate_incidence_rate"))``
+ ) |
||
| 25 | +366 |
- #' @param summarize (`flag`)\cr whether the function should act as an analyze function (`summarize = FALSE`), or a+ } |
||
| 26 | +367 |
- #' summarize function (`summarize = TRUE`). Defaults to `FALSE`.+ |
||
| 27 | +368 |
- #' @param label_fmt (`string`)\cr how labels should be formatted after a row split occurs if `summarize = TRUE`. The+ #' @importFrom grid validDetails |
||
| 28 | +369 |
- #' string should use `"%s"` to represent row split levels, and `"%.labels"` to represent labels supplied to the+ #' @noRd |
||
| 29 | +370 |
- #' `.labels` argument. Defaults to `"%s - %.labels"`.+ validDetails.dynamicSplitText <- function(x) {
|
||
| 30 | +371 |
- #'+ checkmate::assert_character(x$text) |
||
| 31 | +372 |
- #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].+ checkmate::assert_true(grid::is.unit(x$width)) |
||
| 32 | +373 |
- #'+ checkmate::assert_vector(x$width, len = 1) |
||
| 33 | +374 |
- #' @examples+ x |
||
| 34 | +375 |
- #' df <- data.frame(+ } |
||
| 35 | +376 |
- #' USUBJID = as.character(seq(6)),+ |
||
| 36 | +377 |
- #' CNSR = c(0, 1, 1, 0, 0, 0),+ #' @importFrom grid heightDetails |
||
| 37 | +378 |
- #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),+ #' @noRd |
||
| 38 | +379 |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B")),
+ heightDetails.dynamicSplitText <- function(x) {
|
||
| 39 | +380 |
- #' STRATA1 = factor(c("X", "Y", "Y", "X", "X", "Y"))
+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
||
| 40 | +381 |
- #' )+ attr(x$text, "fixed_text") |
||
| 41 | +382 |
- #' df$n_events <- 1 - df$CNSR+ } else {
|
||
| 42 | +383 |
- #'+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 43 | +384 |
- #' @name incidence_rate+ } |
||
| 44 | +385 |
- #' @order 1+ grid::stringHeight(txt) |
||
| 45 | +386 |
- NULL+ } |
||
| 46 | +387 | |||
| 47 | +388 |
- #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the+ #' @importFrom grid widthDetails |
||
| 48 | +389 |
- #' associated confidence interval.+ #' @noRd |
||
| 49 | +390 |
- #'+ widthDetails.dynamicSplitText <- function(x) {
|
||
| 50 | +391 |
- #' @return+ x$width |
||
| 51 | +392 |
- #' * `s_incidence_rate()` returns the following statistics:+ } |
||
| 52 | +393 |
- #' - `person_years`: Total person-years at risk.+ |
||
| 53 | +394 |
- #' - `n_events`: Total number of events observed.+ #' @importFrom grid drawDetails |
||
| 54 | +395 |
- #' - `rate`: Estimated incidence rate.+ #' @noRd |
||
| 55 | +396 |
- #' - `rate_ci`: Confidence interval for the incidence rate.+ drawDetails.dynamicSplitText <- function(x, recording) {
|
||
| 56 | +397 |
- #' - `n_unique`: Total number of patients with at least one event observed.+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
||
| 57 | +398 |
- #' - `n_rate`: Total number of events observed & estimated incidence rate.+ attr(x$text, "fixed_text") |
||
| 58 | +399 |
- #'+ } else {
|
||
| 59 | +400 |
- #' @keywords internal+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 60 | +401 |
- s_incidence_rate <- function(df,+ } |
||
| 61 | +402 |
- .var,+ |
||
| 62 | +403 |
- n_events,+ x$width <- NULL |
||
| 63 | +404 |
- is_event = lifecycle::deprecated(),+ x$label <- txt |
||
| 64 | +405 |
- id_var = "USUBJID",+ x$text <- NULL |
||
| 65 | +406 |
- control = control_incidence_rate()) {
- |
- ||
| 66 | -17x | -
- if (lifecycle::is_present(is_event)) {
+ class(x) <- c("text", class(x)[-1])
|
||
| 67 | -! | +|||
| 407 | +
- checkmate::assert_string(is_event)+ |
|||
| 68 | -! | +|||
| 408 | +
- lifecycle::deprecate_warn(+ grid::grid.draw(x) |
|||
| 69 | -! | +|||
| 409 | +
- "0.9.6", "s_incidence_rate(is_event)", "s_incidence_rate(n_events)"+ } |
|||
| 70 | +410 |
- )+ # nocov end |
||
| 71 | -! | +|||
| 411 | +
- n_events <- is_event+ |
|||
| 72 | -! | +|||
| 412 | +
- df[[n_events]] <- as.numeric(df[[is_event]])+ # Adapted from Paul Murell R Graphics 2nd Edition |
|||
| 73 | +413 |
- }+ # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R |
||
| 74 | +414 |
-
+ split_string <- function(text, width) {
|
||
| 75 | -17x | +415 | +26x |
- assert_df_with_variables(df, list(tte = .var, n_events = n_events))+ strings <- strsplit(text, " ") |
| 76 | -17x | +416 | +26x |
- checkmate::assert_string(.var)+ out_string <- NA |
| 77 | -17x | +417 | +26x |
- checkmate::assert_string(n_events)+ for (string_i in seq_along(strings)) {
|
| 78 | -17x | +418 | +48x |
- checkmate::assert_string(id_var)+ newline_str <- strings[[string_i]] |
| 79 | -17x | +419 | +6x |
- checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ if (length(newline_str) == 0) newline_str <- "" |
| 80 | -17x | +420 | +48x |
- checkmate::assert_integerish(df[[n_events]], any.missing = FALSE)+ if (is.na(out_string[string_i])) {
|
| 81 | -+ | |||
| 421 | +48x |
-
+ out_string[string_i] <- newline_str[[1]][[1]] |
||
| 82 | -17x | +422 | +48x |
- n_unique <- n_available(unique(df[[id_var]][df[[n_events]] == 1]))+ linewidth <- grid::stringWidth(out_string[string_i]) |
| 83 | -17x | +|||
| 423 | +
- input_time_unit <- control$input_time_unit+ } |
|||
| 84 | -17x | +424 | +48x |
- num_pt_year <- control$num_pt_year+ gapwidth <- grid::stringWidth(" ")
|
| 85 | -17x | +425 | +48x |
- conf_level <- control$conf_level+ availwidth <- as.numeric(width) |
| 86 | -17x | +426 | +48x |
- person_years <- sum(df[[.var]], na.rm = TRUE) * (+ if (length(newline_str) > 1) {
|
| 87 | -17x | +427 | +12x |
- 1 * (input_time_unit == "year") ++ for (i in seq(2, length(newline_str))) {
|
| 88 | -17x | +428 | +184x |
- 1 / 12 * (input_time_unit == "month") ++ width_i <- grid::stringWidth(newline_str[i]) |
| 89 | -17x | +|||
| 429 | +
- 1 / 52.14 * (input_time_unit == "week") ++ # Main conversion of allowed text width -> npc units are 0<npc<1. External viewport is used for conversion |
|||
| 90 | -17x | +430 | +184x |
- 1 / 365.24 * (input_time_unit == "day")+ if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
|
| 91 | -+ | |||
| 431 | +177x |
- )+ sep <- " " |
||
| 92 | -17x | +432 | +177x |
- n_events <- sum(df[[n_events]], na.rm = TRUE)+ linewidth <- linewidth + gapwidth + width_i |
| 93 | +433 |
-
+ } else {
|
||
| 94 | -17x | +434 | +7x |
- result <- h_incidence_rate(+ sep <- "\n" |
| 95 | -17x | +435 | +7x |
- person_years,+ linewidth <- width_i |
| 96 | -17x | +|||
| 436 | +
- n_events,+ } |
|||
| 97 | -17x | +437 | +184x |
- control+ out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep) |
| 98 | +438 |
- )- |
- ||
| 99 | -17x | -
- list(+ } |
||
| 100 | -17x | +|||
| 439 | +
- person_years = formatters::with_label(person_years, "Total patient-years at risk"),+ } |
|||
| 101 | -17x | +|||
| 440 | +
- n_events = formatters::with_label(n_events, "Number of adverse events observed"),+ } |
|||
| 102 | -17x | +441 | +26x |
- rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
+ paste(out_string, collapse = "\n") |
| 103 | -17x | +|||
| 442 | +
- rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)),+ } |
|||
| 104 | -17x | +|||
| 443 | +
- n_unique = formatters::with_label(n_unique, "Total number of patients with at least one adverse event"),+ |
|||
| 105 | -17x | +|||
| 444 | +
- n_rate = formatters::with_label(+ #' Update page number |
|||
| 106 | -17x | +|||
| 445 | +
- c(n_events, result$rate),+ #' |
|||
| 107 | -17x | +|||
| 446 | +
- paste("Number of adverse events observed (AE rate per", num_pt_year, "patient-years)")
+ #' Automatically updates page number. |
|||
| 108 | +447 |
- )+ #' |
||
| 109 | +448 |
- )+ #' @param npages (`numeric(1)`)\cr total number of pages. |
||
| 110 | +449 |
- }+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 111 | +450 |
-
+ #' |
||
| 112 | +451 |
- #' @describeIn incidence_rate Formatted analysis function which is used as `afun` in `estimate_incidence_rate()`.+ #' @return Closure that increments the page number. |
||
| 113 | +452 |
#' |
||
| 114 | +453 |
- #' @return+ #' @keywords internal |
||
| 115 | +454 |
- #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()].+ decorate_grob_factory <- function(npages, ...) {
|
||
| 116 | -+ | |||
| 455 | +2x |
- #'+ current_page <- 0 |
||
| 117 | -+ | |||
| 456 | +2x |
- #' @examples+ function(grob) {
|
||
| 118 | -+ | |||
| 457 | +7x |
- #' a_incidence_rate(+ current_page <<- current_page + 1 |
||
| 119 | -+ | |||
| 458 | +7x |
- #' df,+ if (current_page > npages) {
|
||
| 120 | -+ | |||
| 459 | +1x |
- #' .var = "AVAL",+ stop(paste("current page is", current_page, "but max.", npages, "specified."))
|
||
| 121 | +460 |
- #' .df_row = df,+ } |
||
| 122 | -+ | |||
| 461 | +6x |
- #' n_events = "n_events"+ decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
|
||
| 123 | +462 |
- #' )+ } |
||
| 124 | +463 |
- #'+ } |
||
| 125 | +464 |
- #' @export+ |
||
| 126 | +465 |
- a_incidence_rate <- function(df,+ #' Decorate set of `grob`s and add page numbering |
||
| 127 | +466 |
- labelstr = "",+ #' |
||
| 128 | +467 |
- .var,+ #' @description `r lifecycle::badge("stable")`
|
||
| 129 | +468 |
- .df_row,+ #' |
||
| 130 | +469 |
- n_events,+ #' Note that this uses the [decorate_grob_factory()] function. |
||
| 131 | +470 |
- id_var = "USUBJID",+ #' |
||
| 132 | +471 |
- control = control_incidence_rate(),+ #' @param grobs (`list` of `grob`)\cr a list of grid grobs. |
||
| 133 | +472 |
- .stats = NULL,+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 134 | +473 |
- .formats = c(+ #' |
||
| 135 | +474 |
- "person_years" = "xx.x",+ #' @return A decorated grob. |
||
| 136 | +475 |
- "n_events" = "xx",+ #' |
||
| 137 | +476 |
- "rate" = "xx.xx",+ #' @examples |
||
| 138 | +477 |
- "rate_ci" = "(xx.xx, xx.xx)",+ #' library(ggplot2) |
||
| 139 | +478 |
- "n_unique" = "xx",+ #' library(grid) |
||
| 140 | +479 |
- "n_rate" = "xx (xx.x)"+ #' g <- with(data = iris, {
|
||
| 141 | +480 |
- ),+ #' list( |
||
| 142 | +481 |
- .labels = NULL,+ #' ggplot2::ggplotGrob( |
||
| 143 | +482 |
- .indent_mods = NULL,+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 144 | +483 |
- na_str = default_na_str(),+ #' ggplot2::geom_point() |
||
| 145 | +484 |
- label_fmt = "%s - %.labels") {
+ #' ), |
||
| 146 | -16x | +|||
| 485 | +
- checkmate::assert_string(label_fmt)+ #' ggplot2::ggplotGrob( |
|||
| 147 | +486 |
-
+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) + |
||
| 148 | -16x | +|||
| 487 | +
- x_stats <- s_incidence_rate(+ #' ggplot2::geom_point() |
|||
| 149 | -16x | +|||
| 488 | +
- df = df, .var = .var, n_events = n_events, id_var = id_var, control = control+ #' ), |
|||
| 150 | +489 |
- )+ #' ggplot2::ggplotGrob( |
||
| 151 | -16x | +|||
| 490 | +
- if (is.null(unlist(x_stats))) {
+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) + |
|||
| 152 | -! | +|||
| 491 | +
- return(NULL)+ #' ggplot2::geom_point() |
|||
| 153 | +492 |
- }+ #' ), |
||
| 154 | +493 |
-
+ #' ggplot2::ggplotGrob( |
||
| 155 | +494 |
- # Fill in with defaults+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) + |
||
| 156 | -16x | +|||
| 495 | +
- formats_def <- formals()$.formats %>% eval()+ #' ggplot2::geom_point() |
|||
| 157 | -16x | +|||
| 496 | +
- .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))]+ #' ), |
|||
| 158 | -16x | +|||
| 497 | +
- labels_def <- sapply(x_stats, \(x) attributes(x)$label)+ #' ggplot2::ggplotGrob( |
|||
| 159 | -16x | +|||
| 498 | +
- .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))]+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) + |
|||
| 160 | -16x | +|||
| 499 | +
- if (nzchar(labelstr) > 0) {
+ #' ggplot2::geom_point() |
|||
| 161 | -8x | +|||
| 500 | +
- .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
+ #' ), |
|||
| 162 | +501 |
- }+ #' ggplot2::ggplotGrob( |
||
| 163 | +502 |
-
+ #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) + |
||
| 164 | +503 |
- # Fill in with formatting defaults if needed+ #' ggplot2::geom_point() |
||
| 165 | -16x | +|||
| 504 | +
- .stats <- get_stats("estimate_incidence_rate", stats_in = .stats)
+ #' ) |
|||
| 166 | -16x | +|||
| 505 | +
- .formats <- get_formats_from_stats(.stats, .formats)+ #' ) |
|||
| 167 | -16x | +|||
| 506 | +
- .labels <- get_labels_from_stats(.stats, .labels)+ #' }) |
|||
| 168 | -16x | +|||
| 507 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "") |
|||
| 169 | +508 |
-
+ #' |
||
| 170 | -16x | +|||
| 509 | +
- x_stats <- x_stats[.stats]+ #' draw_grob(lg[[1]]) |
|||
| 171 | +510 |
-
+ #' draw_grob(lg[[2]]) |
||
| 172 | -16x | +|||
| 511 | +
- in_rows(+ #' draw_grob(lg[[6]]) |
|||
| 173 | -16x | +|||
| 512 | +
- .list = x_stats,+ #' |
|||
| 174 | -16x | +|||
| 513 | +
- .formats = .formats,+ #' @export |
|||
| 175 | -16x | +|||
| 514 | +
- .labels = .labels,+ decorate_grob_set <- function(grobs, ...) {
|
|||
| 176 | -16x | +515 | +1x |
- .indent_mods = .indent_mods,+ n <- length(grobs) |
| 177 | -16x | +516 | +1x |
- .format_na_strs = na_str+ lgf <- decorate_grob_factory(npages = n, ...) |
| 178 | -+ | |||
| 517 | +1x |
- )+ lapply(grobs, lgf) |
||
| 179 | +518 |
} |
| 180 | +1 |
-
+ #' Control function for descriptive statistics |
||
| 181 | +2 |
- #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments+ #' |
||
| 182 | +3 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 183 | +4 |
#' |
||
| 184 | +5 |
- #' @return+ #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify |
||
| 185 | +6 |
- #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions,+ #' details for [s_summary()]. This function family is mainly used by [analyze_vars()]. |
||
| 186 | +7 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 187 | +8 |
- #' the statistics from `s_incidence_rate()` to the table layout.+ #' @inheritParams argument_convention |
||
| 188 | +9 |
- #'+ #' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate. |
||
| 189 | +10 |
- #' @examples+ #' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used. |
||
| 190 | +11 |
- #' basic_table(show_colcounts = TRUE) %>%+ #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`. |
||
| 191 | +12 |
- #' split_cols_by("ARM") %>%
+ #' This differs from R's default. See more about `type` in [stats::quantile()]. |
||
| 192 | +13 |
- #' estimate_incidence_rate(+ #' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating |
||
| 193 | +14 |
- #' vars = "AVAL",+ #' p-value. |
||
| 194 | +15 |
- #' n_events = "n_events",+ #' |
||
| 195 | +16 |
- #' control = control_incidence_rate(+ #' @return A list of components with the same names as the arguments. |
||
| 196 | +17 |
- #' input_time_unit = "month",+ #' |
||
| 197 | +18 |
- #' num_pt_year = 100+ #' @export |
||
| 198 | +19 |
- #' )+ control_analyze_vars <- function(conf_level = 0.95, |
||
| 199 | +20 |
- #' ) %>%+ quantiles = c(0.25, 0.75), |
||
| 200 | +21 |
- #' build_table(df)+ quantile_type = 2, |
||
| 201 | +22 |
- #'+ test_mean = 0) {
|
||
| 202 | -+ | |||
| 23 | +1091x |
- #' # summarize = TRUE+ checkmate::assert_vector(quantiles, len = 2) |
||
| 203 | -+ | |||
| 24 | +1091x |
- #' basic_table(show_colcounts = TRUE) %>%+ checkmate::assert_int(quantile_type, lower = 1, upper = 9) |
||
| 204 | -+ | |||
| 25 | +1091x |
- #' split_cols_by("ARM") %>%
+ checkmate::assert_numeric(test_mean) |
||
| 205 | -+ | |||
| 26 | +1091x |
- #' split_rows_by("STRATA1", child_labels = "visible") %>%
+ lapply(quantiles, assert_proportion_value) |
||
| 206 | -+ | |||
| 27 | +1090x |
- #' estimate_incidence_rate(+ assert_proportion_value(conf_level) |
||
| 207 | -+ | |||
| 28 | +1089x |
- #' vars = "AVAL",+ list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean) |
||
| 208 | +29 |
- #' n_events = "n_events",+ } |
||
| 209 | +30 |
- #' .stats = c("n_unique", "n_rate"),
+
|
||
| 210 | +31 |
- #' summarize = TRUE,+ #' Analyze variables |
||
| 211 | +32 |
- #' label_fmt = "%.labels"+ #' |
||
| 212 | +33 |
- #' ) %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 213 | +34 |
- #' build_table(df)+ #' |
||
| 214 | +35 |
- #'+ #' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3 |
||
| 215 | +36 |
- #' @export+ #' generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics for |
||
| 216 | +37 |
- #' @order 2+ #' numeric variables can be viewed by running `get_stats("analyze_vars_numeric")` and for non-numeric variables by
|
||
| 217 | +38 |
- estimate_incidence_rate <- function(lyt,+ #' running `get_stats("analyze_vars_counts")`. Use the `.stats` parameter to specify the statistics to include in your
|
||
| 218 | +39 |
- vars,+ #' output summary table. |
||
| 219 | +40 |
- n_events,+ #' |
||
| 220 | +41 |
- id_var = "USUBJID",+ #' @details |
||
| 221 | +42 |
- control = control_incidence_rate(),+ #' **Automatic digit formatting:** The number of digits to display can be automatically determined from the analyzed |
||
| 222 | +43 |
- na_str = default_na_str(),+ #' variable(s) (`vars`) for certain statistics by setting the statistic format to `"auto"` in `.formats`. |
||
| 223 | +44 |
- nested = TRUE,+ #' This utilizes the [format_auto()] formatting function. Note that only data for the current row & variable (for all |
||
| 224 | +45 |
- summarize = FALSE,+ #' columns) will be considered (`.df_row[[.var]]`, see [`rtables::additional_fun_params`]) and not the whole dataset. |
||
| 225 | +46 |
- label_fmt = "%s - %.labels",+ #' |
||
| 226 | +47 |
- ...,+ #' @inheritParams argument_convention |
||
| 227 | +48 |
- show_labels = "hidden",+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 228 | +49 |
- table_names = vars,+ #' |
||
| 229 | +50 |
- .stats = c("person_years", "n_events", "rate", "rate_ci"),
+ #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric"))``
|
||
| 230 | +51 |
- .formats = NULL,+ #' |
||
| 231 | +52 |
- .labels = NULL,+ #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts"))``
|
||
| 232 | +53 |
- .indent_mods = NULL) {
- |
- ||
| 233 | -5x | -
- extra_args <- c(+ #' |
||
| 234 | -5x | +|||
| 54 | +
- list(.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str),+ #' @name analyze_variables |
|||
| 235 | -5x | +|||
| 55 | +
- list(n_events = n_events, id_var = id_var, control = control, label_fmt = label_fmt, ...)+ #' @order 1 |
|||
| 236 | +56 |
- )+ NULL |
||
| 237 | +57 | |||
| 238 | -5x | +|||
| 58 | +
- if (!summarize) {
+ #' @describeIn analyze_variables S3 generic function to produces a variable summary. |
|||
| 239 | -3x | +|||
| 59 | +
- analyze(+ #' |
|||
| 240 | -3x | +|||
| 60 | +
- lyt,+ #' @return |
|||
| 241 | -3x | +|||
| 61 | +
- vars,+ #' * `s_summary()` returns different statistics depending on the class of `x`. |
|||
| 242 | -3x | +|||
| 62 | +
- show_labels = show_labels,+ #' |
|||
| 243 | -3x | +|||
| 63 | +
- table_names = table_names,+ #' @export |
|||
| 244 | -3x | +|||
| 64 | +
- afun = a_incidence_rate,+ s_summary <- function(x, |
|||
| 245 | -3x | +|||
| 65 | +
- na_str = na_str,+ na.rm = TRUE, # nolint |
|||
| 246 | -3x | +|||
| 66 | +
- nested = nested,+ denom, |
|||
| 247 | -3x | +|||
| 67 | +
- extra_args = extra_args+ .N_row, # nolint |
|||
| 248 | +68 |
- )+ .N_col, # nolint |
||
| 249 | +69 |
- } else {
+ .var, |
||
| 250 | -2x | +|||
| 70 | +
- summarize_row_groups(+ ...) {
|
|||
| 251 | -2x | +71 | +1609x |
- lyt,+ checkmate::assert_flag(na.rm) |
| 252 | -2x | +72 | +1609x |
- vars,+ UseMethod("s_summary", x)
|
| 253 | -2x | +|||
| 73 | +
- cfun = a_incidence_rate,+ } |
|||
| 254 | -2x | +|||
| 74 | +
- na_str = na_str,+ |
|||
| 255 | -2x | +|||
| 75 | +
- extra_args = extra_args+ #' @describeIn analyze_variables Method for `numeric` class. |
|||
| 256 | +76 |
- )+ #' |
||
| 257 | +77 |
- }+ #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using |
||
| 258 | +78 |
- }+ #' the helper function [control_analyze_vars()]. Some possible parameter options are: |
| 1 | +79 |
- #' Stack multiple grobs+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median. |
|
| 2 | +80 |
- #'+ #' * `quantiles` (`numeric(2)`)\cr vector of length two to specify the quantiles. |
|
| 3 | +81 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' * `quantile_type` (`numeric(1)`)\cr between 1 and 9 selecting quantile algorithms to be used. |
|
| 4 | +82 |
- #'+ #' See more about `type` in [stats::quantile()]. |
|
| 5 | +83 |
- #' Stack grobs as a new grob with 1 column and multiple rows layout.+ #' * `test_mean` (`numeric(1)`)\cr value to test against the mean under the null hypothesis when calculating p-value. |
|
| 6 | +84 |
#' |
|
| 7 | +85 |
- #' @param ... grobs.+ #' @return |
|
| 8 | +86 |
- #' @param grobs (`list` of `grob`)\cr a list of grobs.+ #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items: |
|
| 9 | +87 |
- #' @param padding (`grid::unit`)\cr unit of length 1, space between each grob.+ #' * `n`: The [length()] of `x`. |
|
| 10 | +88 |
- #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`).- |
- |
| 11 | -- |
- #' @param name (`string`)\cr a character identifier for the grob.- |
- |
| 12 | -- |
- #' @param gp (`gpar`)\cr a [gpar()] object.- |
- |
| 13 | -- |
- #'- |
- |
| 14 | -- |
- #' @return A `grob`.- |
- |
| 15 | -- |
- #'- |
- |
| 16 | -- |
- #' @examples- |
- |
| 17 | -- |
- #' library(grid)- |
- |
| 18 | -- |
- #'- |
- |
| 19 | -- |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))- |
- |
| 20 | -- |
- #' g2 <- circleGrob(gp = gpar(col = "red"))- |
- |
| 21 | -- |
- #' g3 <- textGrob("TEST TEXT")
- |
- |
| 22 | -- |
- #' grid.newpage()- |
- |
| 23 | -- |
- #' grid.draw(stack_grobs(g1, g2, g3))- |
- |
| 24 | -- |
- #'- |
- |
| 25 | -- |
- #' showViewport()- |
- |
| 26 | -- |
- #'- |
- |
| 27 | -- |
- #' grid.newpage()- |
- |
| 28 | -- |
- #' pushViewport(viewport(layout = grid.layout(1, 2)))- |
- |
| 29 | -- |
- #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)- |
- |
| 30 | -- |
- #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))- |
- |
| 31 | -- |
- #'- |
- |
| 32 | -- |
- #' showViewport()- |
- |
| 33 | -- |
- #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)- |
- |
| 34 | -- |
- #'- |
- |
| 35 | -- |
- #' @export- |
- |
| 36 | -- |
- stack_grobs <- function(...,- |
- |
| 37 | -- |
- grobs = list(...),- |
- |
| 38 | -- |
- padding = grid::unit(2, "line"),- |
- |
| 39 | -- |
- vp = NULL,- |
- |
| 40 | -- |
- gp = NULL,- |
- |
| 41 | -- |
- name = NULL) {
- |
- |
| 42 | -4x | -
- lifecycle::deprecate_warn(- |
- |
| 43 | -4x | -
- "0.9.4",- |
- |
| 44 | -4x | -
- "stack_grobs()",- |
- |
| 45 | -4x | -
- details = "`tern` plotting functions no longer generate `grob` objects."- |
- |
| 46 | -- |
- )- |
- |
| 47 | -- | - - | -|
| 48 | -4x | -
- checkmate::assert_true(- |
- |
| 49 | -4x | -
- all(vapply(grobs, grid::is.grob, logical(1)))- |
- |
| 50 | -- |
- )- |
- |
| 51 | -- | - - | -|
| 52 | -4x | -
- if (length(grobs) == 1) {
- |
- |
| 53 | -1x | -
- return(grobs[[1]])- |
- |
| 54 | -- |
- }- |
- |
| 55 | -- | - - | -|
| 56 | -3x | -
- n_layout <- 2 * length(grobs) - 1- |
- |
| 57 | -3x | -
- hts <- lapply(- |
- |
| 58 | -3x | -
- seq(1, n_layout),- |
- |
| 59 | -3x | -
- function(i) {
- |
- |
| 60 | -39x | -
- if (i %% 2 != 0) {
- |
- |
| 61 | -21x | -
- grid::unit(1, "null")- |
- |
| 62 | -- |
- } else {
- |
- |
| 63 | -18x | -
- padding- |
- |
| 64 | -- |
- }- |
- |
| 65 | -- |
- }- |
- |
| 66 | -- |
- )- |
- |
| 67 | -3x | -
- hts <- do.call(grid::unit.c, hts)- |
- |
| 68 | -- | - - | -|
| 69 | -3x | -
- main_vp <- grid::viewport(- |
- |
| 70 | -3x | -
- layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)- |
- |
| 71 | -- |
- )- |
- |
| 72 | -- | - - | -|
| 73 | -3x | -
- nested_grobs <- Map(function(g, i) {
- |
- |
| 74 | -21x | -
- grid::gTree(- |
- |
| 75 | -21x | -
- children = grid::gList(g),- |
- |
| 76 | -21x | -
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)- |
- |
| 77 | -- |
- )- |
- |
| 78 | -3x | -
- }, grobs, seq_along(grobs) * 2 - 1)- |
- |
| 79 | -- | - - | -|
| 80 | -3x | -
- grobs_mainvp <- grid::gTree(- |
- |
| 81 | -3x | -
- children = do.call(grid::gList, nested_grobs),- |
- |
| 82 | -3x | -
- vp = main_vp- |
- |
| 83 | -- |
- )+ #' * `sum`: The [sum()] of `x`. |
|
| 84 | -- | - - | -|
| 85 | -3x | -
- grid::gTree(- |
- |
| 86 | -3x | -
- children = grid::gList(grobs_mainvp),- |
- |
| 87 | -3x | -
- vp = vp,- |
- |
| 88 | -3x | -
- gp = gp,- |
- |
| 89 | -3x | +
- name = name+ #' * `mean`: The [mean()] of `x`. |
|
| 90 |
- )+ #' * `sd`: The [stats::sd()] of `x`. |
||
| 91 |
- }+ #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`). |
||
| 92 |
-
+ #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`. |
||
| 93 |
- #' Arrange multiple grobs+ #' * `mean_se`: The [mean()] of `x` and its standard error (see above). |
||
| 94 |
- #'+ #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]). |
||
| 95 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]). |
||
| 96 |
- #'+ #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]). |
||
| 97 |
- #' Arrange grobs as a new grob with `n * m (rows * cols)` layout.+ #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]). |
||
| 98 |
- #'+ #' * `median`: The [stats::median()] of `x`. |
||
| 99 |
- #' @inheritParams stack_grobs+ #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`, |
||
| 100 |
- #' @param ncol (`integer(1)`)\cr number of columns in layout.+ #' where `xc` = `x` - [stats::median()]). |
||
| 101 |
- #' @param nrow (`integer(1)`)\cr number of rows in layout.+ #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]). |
||
| 102 |
- #' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob.+ #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]). |
||
| 103 |
- #' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob.+ #' * `iqr`: The [stats::IQR()] of `x`. |
||
| 104 |
- #'+ #' * `range`: The [range_noinf()] of `x`. |
||
| 105 |
- #' @return A `grob`.+ #' * `min`: The [max()] of `x`. |
||
| 106 |
- #'+ #' * `max`: The [min()] of `x`. |
||
| 107 |
- #' @examples+ #' * `median_range`: The [median()] and [range_noinf()] of `x`. |
||
| 108 |
- #' library(grid)+ #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100). |
||
| 109 |
- #'+ #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`). |
||
| 110 |
- #' \donttest{
+ #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`). |
||
| 111 |
- #' num <- lapply(1:9, textGrob)+ #' |
||
| 112 |
- #' grid::grid.newpage()+ #' @note |
||
| 113 |
- #' grid.draw(arrange_grobs(grobs = num, ncol = 2))+ #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in |
||
| 114 |
- #'+ #' `rtables` when the intersection of a column and a row delimits an empty data selection. |
||
| 115 |
- #' showViewport()+ #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter |
||
| 116 |
- #'+ #' being standard behavior in R. |
||
| 117 |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ #' |
||
| 118 |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ #' @method s_summary numeric |
||
| 119 |
- #' g3 <- textGrob("TEST TEXT")
+ #' |
||
| 120 |
- #' grid::grid.newpage()+ #' @examples |
||
| 121 |
- #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))+ #' # `s_summary.numeric` |
||
| 123 |
- #' showViewport()+ #' ## Basic usage: empty numeric returns NA-filled items. |
||
| 124 |
- #'+ #' s_summary(numeric()) |
||
| 125 |
- #' grid::grid.newpage()+ #' |
||
| 126 |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))+ #' ## Management of NA values. |
||
| 127 |
- #'+ #' x <- c(NA_real_, 1) |
||
| 128 |
- #' grid::grid.newpage()+ #' s_summary(x, na.rm = TRUE) |
||
| 129 |
- #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))+ #' s_summary(x, na.rm = FALSE) |
||
| 130 |
- #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)+ #' |
||
| 131 |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))+ #' x <- c(NA_real_, 1, 2) |
||
| 132 |
- #'+ #' s_summary(x, stats = NULL) |
||
| 133 |
- #' showViewport()+ #' |
||
| 134 |
- #' }+ #' ## Benefits in `rtables` contructions: |
||
| 135 |
- #' @export+ #' dta_test <- data.frame( |
||
| 136 |
- arrange_grobs <- function(...,+ #' Group = rep(LETTERS[1:3], each = 2), |
||
| 137 |
- grobs = list(...),+ #' sub_group = rep(letters[1:2], each = 3), |
||
| 138 |
- ncol = NULL, nrow = NULL,+ #' x = 1:6 |
||
| 139 |
- padding_ht = grid::unit(2, "line"),+ #' ) |
||
| 140 |
- padding_wt = grid::unit(2, "line"),+ #' |
||
| 141 |
- vp = NULL,+ #' ## The summary obtained in with `rtables`: |
||
| 142 |
- gp = NULL,+ #' basic_table() %>% |
||
| 143 |
- name = NULL) {
+ #' split_cols_by(var = "Group") %>% |
||
| 144 | -5x | +
- lifecycle::deprecate_warn(+ #' split_rows_by(var = "sub_group") %>% |
|
| 145 | -5x | +
- "0.9.4",+ #' analyze(vars = "x", afun = s_summary) %>% |
|
| 146 | -5x | +
- "arrange_grobs()",+ #' build_table(df = dta_test) |
|
| 147 | -5x | +
- details = "`tern` plotting functions no longer generate `grob` objects."+ #' |
|
| 148 |
- )+ #' ## By comparison with `lapply`: |
||
| 149 |
-
+ #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group))) |
||
| 150 | -5x | +
- checkmate::assert_true(+ #' lapply(X, function(x) s_summary(x$x)) |
|
| 151 | -5x | +
- all(vapply(grobs, grid::is.grob, logical(1)))+ #' |
|
| 152 |
- )+ #' @export |
||
| 153 |
-
+ s_summary.numeric <- function(x, |
||
| 154 | -5x | +
- if (length(grobs) == 1) {
+ na.rm = TRUE, # nolint |
|
| 155 | -1x | +
- return(grobs[[1]])+ denom, |
|
| 156 |
- }+ .N_row, # nolint |
||
| 157 |
-
+ .N_col, # nolint |
||
| 158 | -4x | +
- if (is.null(ncol) && is.null(nrow)) {
+ .var, |
|
| 159 | -1x | +
- ncol <- 1+ control = control_analyze_vars(), |
|
| 160 | -1x | +
- nrow <- ceiling(length(grobs) / ncol)+ ...) {
|
|
| 161 | -3x | +1134x |
- } else if (!is.null(ncol) && is.null(nrow)) {
+ checkmate::assert_numeric(x) |
| 162 | -1x | +
- nrow <- ceiling(length(grobs) / ncol)+ |
|
| 163 | -2x | +1134x |
- } else if (is.null(ncol) && !is.null(nrow)) {
+ if (na.rm) {
|
| 164 | -! | +1132x |
- ncol <- ceiling(length(grobs) / nrow)+ x <- x[!is.na(x)] |
| 167 | -4x | +1134x |
- if (ncol * nrow < length(grobs)) {
+ y <- list() |
| 168 | -1x | +
- stop("specififed ncol and nrow are not enough for arranging the grobs ")
+
|
|
| 169 | -+ | 1134x |
- }+ y$n <- c("n" = length(x))
|
| 171 | -3x | +1134x |
- if (ncol == 1) {
+ y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
|
| 172 | -2x | +
- return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))+ |
|
| 173 | -+ | 1134x |
- }+ y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
|
| 175 | -1x | +1134x |
- n_col <- 2 * ncol - 1+ y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
|
| 176 | -1x | +
- n_row <- 2 * nrow - 1+ |
|
| 177 | -1x | +1134x |
- hts <- lapply(+ y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
|
| 178 | -1x | +
- seq(1, n_row),+ |
|
| 179 | -1x | +1134x |
- function(i) {
+ y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE)) |
| 180 | -5x | +
- if (i %% 2 != 0) {
+
|
|
| 181 | -3x | +1134x |
- grid::unit(1, "null")+ y$mean_se <- c(y$mean, y$se) |
| 182 |
- } else {
+
|
||
| 183 | -2x | +1134x |
- padding_ht+ mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
| 184 | -+ | 1134x |
- }+ y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
|
| 185 |
- }+ |
||
| 186 | -+ | 1134x |
- )+ mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n) |
| 187 | -1x | +1134x |
- hts <- do.call(grid::unit.c, hts)+ names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
|
| 188 | -+ | 1134x |
-
+ y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE") |
| 189 | -1x | +
- wts <- lapply(+ |
|
| 190 | -1x | +1134x |
- seq(1, n_col),+ mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) |
| 191 | -1x | +1134x |
- function(i) {
+ names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
|
| 192 | -5x | +1134x |
- if (i %% 2 != 0) {
+ y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD") |
| 193 | -3x | +
- grid::unit(1, "null")+ |
|
| 194 | -+ | 1134x |
- } else {
+ mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2) |
| 195 | -2x | +1134x |
- padding_wt+ y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
|
| 196 |
- }+ |
||
| 197 | -+ | 1134x |
- }+ y$median <- c("median" = stats::median(x, na.rm = FALSE))
|
| 198 |
- )+ |
||
| 199 | -1x | +1134x |
- wts <- do.call(grid::unit.c, wts)+ y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
|
| 201 | -1x | +1134x |
- main_vp <- grid::viewport(+ median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
| 202 | -1x | +1134x |
- layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)+ y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
|
| 203 |
- )+ |
||
| 204 | -+ | 1134x |
-
+ q <- control$quantiles |
| 205 | -1x | +1134x |
- nested_grobs <- list()+ if (any(is.na(x))) {
|
| 206 | -1x | +2x |
- k <- 0+ qnts <- rep(NA_real_, length(q)) |
| 207 | -1x | +
- for (i in seq(nrow) * 2 - 1) {
+ } else {
|
|
| 208 | -3x | +1132x |
- for (j in seq(ncol) * 2 - 1) {
+ qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE) |
| 209 | -9x | +
- k <- k + 1+ } |
|
| 210 | -9x | +1134x |
- if (k <= length(grobs)) {
+ names(qnts) <- paste("quantile", q, sep = "_")
|
| 211 | -9x | +1134x |
- nested_grobs <- c(+ y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile")) |
| 212 | -9x | +
- nested_grobs,+ |
|
| 213 | -9x | +1134x |
- list(grid::gTree(+ y$iqr <- c("iqr" = ifelse(
|
| 214 | -9x | +1134x |
- children = grid::gList(grobs[[k]]),+ any(is.na(x)), |
| 215 | -9x | +1134x |
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)+ NA_real_, |
| 216 | -+ | 1134x |
- ))+ stats::IQR(x, na.rm = FALSE, type = control$quantile_type) |
| 217 |
- )+ )) |
||
| 218 |
- }+ |
||
| 219 | -+ | 1134x |
- }+ y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
|
| 220 | -+ | 1134x |
- }+ y$min <- y$range[1] |
| 221 | -1x | +1134x |
- grobs_mainvp <- grid::gTree(+ y$max <- y$range[2] |
| 222 | -1x | +
- children = do.call(grid::gList, nested_grobs),+ |
|
| 223 | -1x | +1134x |
- vp = main_vp+ y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)") |
| 224 |
- )+ |
||
| 225 | -+ | 1134x |
-
+ y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
|
| 226 | -1x | +
- grid::gTree(+ |
|
| 227 | -1x | +
- children = grid::gList(grobs_mainvp),+ # Convert negative values to NA for log calculation. |
|
| 228 | -1x | +1134x |
- vp = vp,+ x_no_negative_vals <- x |
| 229 | -1x | +1134x |
- gp = gp,+ x_no_negative_vals[x_no_negative_vals <= 0] <- NA |
| 230 | -1x | +1134x |
- name = name+ y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
|
| 231 | -+ | 1134x |
- )+ geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE) |
| 232 | -+ | 1134x |
- }+ y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
|
| 234 | -+ | 1134x |
- #' Draw `grob`+ y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
|
| 235 |
- #'+ |
||
| 236 | -+ | 1134x |
- #' @description `r lifecycle::badge("deprecated")`
+ y |
| 237 |
- #'+ } |
||
| 238 |
- #' Draw grob on device page.+ |
||
| 239 |
- #'+ #' @describeIn analyze_variables Method for `factor` class. |
||
| 240 |
- #' @param grob (`grob`)\cr grid object.+ #' |
||
| 241 |
- #' @param newpage (`flag`)\cr draw on a new page.+ #' @return |
||
| 242 |
- #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`).+ #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items: |
||
| 243 |
- #'+ #' * `n`: The [length()] of `x`. |
||
| 244 |
- #' @return A `grob`.+ #' * `count`: A list with the number of cases for each level of the factor `x`. |
||
| 245 |
- #'+ #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the |
||
| 246 |
- #' @examples+ #' factor `x` relative to the denominator, or `NA` if the denominator is zero. |
||
| 247 |
- #' library(dplyr)+ #' |
||
| 248 |
- #' library(grid)+ #' @note |
||
| 249 |
- #'+ #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element |
||
| 250 |
- #' \donttest{
+ #' per factor level. If there are no levels in `x`, the function fails. |
||
| 251 |
- #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
||
| 252 |
- #' rect %>% draw_grob(vp = grid::viewport(angle = 45))+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
||
| 253 |
- #'+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
||
| 254 |
- #' num <- lapply(1:10, textGrob)+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
||
| 255 |
- #' num %>%+ #' |
||
| 256 |
- #' arrange_grobs(grobs = .) %>%+ #' @method s_summary factor |
||
| 257 |
- #' draw_grob()+ #' |
||
| 258 |
- #' showViewport()+ #' @examples |
||
| 259 |
- #' }+ #' # `s_summary.factor` |
||
| 261 |
- #' @export+ #' ## Basic usage: |
||
| 262 |
- draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
+ #' s_summary(factor(c("a", "a", "b", "c", "a")))
|
||
| 263 | -3x | +
- lifecycle::deprecate_warn(+ #' |
|
| 264 | -3x | +
- "0.9.4",+ #' # Empty factor returns zero-filled items. |
|
| 265 | -3x | +
- "draw_grob()",+ #' s_summary(factor(levels = c("a", "b", "c")))
|
|
| 266 | -3x | +
- details = "`tern` plotting functions no longer generate `grob` objects."+ #' |
|
| 267 |
- )+ #' ## Management of NA values. |
||
| 268 |
-
+ #' x <- factor(c(NA, "Female")) |
||
| 269 | -3x | +
- if (newpage) {
+ #' x <- explicit_na(x) |
|
| 270 | -3x | +
- grid::grid.newpage()+ #' s_summary(x, na.rm = TRUE) |
|
| 271 |
- }+ #' s_summary(x, na.rm = FALSE) |
||
| 272 | -3x | +
- if (!is.null(vp)) {
+ #' |
|
| 273 | -1x | +
- grid::pushViewport(vp)+ #' ## Different denominators. |
|
| 274 |
- }+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
||
| 275 | -3x | +
- grid::grid.draw(grob)+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
|
| 276 |
- }+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
||
| 277 |
-
+ #' |
||
| 278 |
- tern_grob <- function(x) {
+ #' @export |
||
| 279 | -! | +
- class(x) <- unique(c("ternGrob", class(x)))
+ s_summary.factor <- function(x, |
|
| 280 | -! | +
- x+ na.rm = TRUE, # nolint |
|
| 281 |
- }+ denom = c("n", "N_col", "N_row"),
|
||
| 282 |
-
+ .N_row, # nolint |
||
| 283 |
- #' @keywords internal+ .N_col, # nolint |
||
| 284 |
- print.ternGrob <- function(x, ...) {
+ ...) {
|
||
| 285 | -! | +302x |
- grid::grid.newpage()+ assert_valid_factor(x) |
| 286 | -! | +
- grid::grid.draw(x)+ |
|
| 287 | -+ | 299x |
- }+ if (na.rm) {
|
| 1 | -+ | |||
| 288 | +290x |
- #' Proportion difference estimation+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
||
| 2 | +289 |
- #'+ } else {
|
||
| 3 | -+ | |||
| 290 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ x <- x %>% explicit_na(label = "NA") |
||
| 4 | +291 |
- #'+ } |
||
| 5 | +292 |
- #' The analysis function [estimate_proportion_diff()] creates a layout element to estimate the difference in proportion+ |
||
| 6 | -+ | |||
| 293 | +299x |
- #' of responders within a studied population. The primary analysis variable, `vars`, is a logical variable indicating+ y <- list() |
||
| 7 | +294 |
- #' whether a response has occurred for each record. See the `method` parameter for options of methods to use when+ |
||
| 8 | -+ | |||
| 295 | +299x |
- #' constructing the confidence interval of the proportion difference. A stratification variable can be supplied via the+ y$n <- length(x) |
||
| 9 | +296 |
- #' `strata` element of the `variables` argument.+ |
||
| 10 | -+ | |||
| 297 | +299x |
- #'+ y$count <- as.list(table(x, useNA = "ifany")) |
||
| 11 | +298 |
- #'+ |
||
| 12 | -+ | |||
| 299 | +299x |
- #' @inheritParams prop_diff_strat_nc+ denom <- match.arg(denom) %>% |
||
| 13 | -+ | |||
| 300 | +299x |
- #' @inheritParams argument_convention+ switch( |
||
| 14 | -+ | |||
| 301 | +299x |
- #' @param method (`string`)\cr the method used for the confidence interval estimation.+ n = length(x), |
||
| 15 | -+ | |||
| 302 | +299x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ N_row = .N_row, |
||
| 16 | -+ | |||
| 303 | +299x |
- #'+ N_col = .N_col |
||
| 17 | +304 |
- #' Options are: ``r shQuote(get_stats("estimate_proportion_diff"))``
+ ) |
||
| 18 | +305 |
- #'+ |
||
| 19 | -+ | |||
| 306 | +299x |
- #' @seealso [d_proportion_diff()]+ y$count_fraction <- lapply( |
||
| 20 | -+ | |||
| 307 | +299x |
- #'+ y$count, |
||
| 21 | -+ | |||
| 308 | +299x |
- #' @name prop_diff+ function(x) {
|
||
| 22 | -+ | |||
| 309 | +2172x |
- #' @order 1+ c(x, ifelse(denom > 0, x / denom, 0)) |
||
| 23 | +310 |
- NULL+ } |
||
| 24 | +311 |
-
+ ) |
||
| 25 | -+ | |||
| 312 | +299x |
- #' @describeIn prop_diff Statistics function estimating the difference+ y$fraction <- lapply( |
||
| 26 | -+ | |||
| 313 | +299x |
- #' in terms of responder proportion.+ y$count, |
||
| 27 | -+ | |||
| 314 | +299x |
- #'+ function(count) c("num" = count, "denom" = denom)
|
||
| 28 | +315 |
- #' @return+ ) |
||
| 29 | +316 |
- #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`.+ |
||
| 30 | -+ | |||
| 317 | +299x |
- #'+ y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))
|
||
| 31 | +318 |
- #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are+ + |
+ ||
| 319 | +299x | +
+ y |
||
| 32 | +320 |
- #' not permitted.+ } |
||
| 33 | +321 |
- #'+ |
||
| 34 | +322 |
- #' @examples+ #' @describeIn analyze_variables Method for `character` class. This makes an automatic |
||
| 35 | +323 |
- #' s_proportion_diff(+ #' conversion to factor (with a warning) and then forwards to the method for factors. |
||
| 36 | +324 |
- #' df = subset(dta, grp == "A"),+ #' |
||
| 37 | +325 |
- #' .var = "rsp",+ #' @param verbose (`flag`)\cr defaults to `TRUE`, which prints out warnings and messages. It is mainly used |
||
| 38 | +326 |
- #' .ref_group = subset(dta, grp == "B"),+ #' to print out information about factor casting. |
||
| 39 | +327 |
- #' .in_ref_col = FALSE,+ #' |
||
| 40 | +328 |
- #' conf_level = 0.90,+ #' @note |
||
| 41 | +329 |
- #' method = "ha"+ #' * Automatic conversion of character to factor does not guarantee that the table |
||
| 42 | +330 |
- #' )+ #' can be generated correctly. In particular for sparse tables this very likely can fail. |
||
| 43 | +331 |
- #'+ #' It is therefore better to always pre-process the dataset such that factors are manually |
||
| 44 | +332 |
- #' # CMH example with strata+ #' created from character variables before passing the dataset to [rtables::build_table()]. |
||
| 45 | +333 |
- #' s_proportion_diff(+ #' |
||
| 46 | +334 |
- #' df = subset(dta, grp == "A"),+ #' @method s_summary character |
||
| 47 | +335 |
- #' .var = "rsp",+ #' |
||
| 48 | +336 |
- #' .ref_group = subset(dta, grp == "B"),+ #' @examples |
||
| 49 | +337 |
- #' .in_ref_col = FALSE,+ #' # `s_summary.character` |
||
| 50 | +338 |
- #' variables = list(strata = c("f1", "f2")),
+ #' |
||
| 51 | +339 |
- #' conf_level = 0.90,+ #' ## Basic usage: |
||
| 52 | +340 |
- #' method = "cmh"+ #' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
|
||
| 53 | +341 |
- #' )+ #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
|
||
| 54 | +342 |
#' |
||
| 55 | +343 |
#' @export |
||
| 56 | +344 |
- s_proportion_diff <- function(df,+ s_summary.character <- function(x, |
||
| 57 | +345 |
- .var,+ na.rm = TRUE, # nolint |
||
| 58 | +346 |
- .ref_group,+ denom = c("n", "N_col", "N_row"),
|
||
| 59 | +347 |
- .in_ref_col,+ .N_row, # nolint |
||
| 60 | +348 |
- variables = list(strata = NULL),+ .N_col, # nolint |
||
| 61 | +349 |
- conf_level = 0.95,+ .var, |
||
| 62 | +350 |
- method = c(+ verbose = TRUE, |
||
| 63 | +351 |
- "waldcc", "wald", "cmh",+ ...) {
|
||
| 64 | -+ | |||
| 352 | +8x |
- "ha", "newcombe", "newcombecc",+ if (na.rm) {
+ |
+ ||
| 353 | +7x | +
+ y <- as_factor_keep_attributes(x, verbose = verbose) |
||
| 65 | +354 |
- "strat_newcombe", "strat_newcombecc"+ } else {
+ |
+ ||
| 355 | +1x | +
+ y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA") |
||
| 66 | +356 |
- ),+ } |
||
| 67 | +357 |
- weights_method = "cmh") {
+
|
||
| 68 | -2x | +358 | +8x |
- method <- match.arg(method)+ s_summary( |
| 69 | -2x | +359 | +8x |
- if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
+ x = y, |
| 70 | -! | +|||
| 360 | +8x |
- stop(paste(+ na.rm = na.rm, |
||
| 71 | -! | +|||
| 361 | +8x |
- "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",+ denom = denom, |
||
| 72 | -! | +|||
| 362 | +8x |
- "permitted. Please choose a different method."+ .N_row = .N_row,+ |
+ ||
| 363 | +8x | +
+ .N_col = .N_col, |
||
| 73 | +364 |
- ))+ ... |
||
| 74 | +365 |
- }+ ) |
||
| 75 | -2x | +|||
| 366 | +
- y <- list(diff = "", diff_ci = "")+ } |
|||
| 76 | +367 | |||
| 77 | -2x | +|||
| 368 | +
- if (!.in_ref_col) {
+ #' @describeIn analyze_variables Method for `logical` class. |
|||
| 78 | -2x | +|||
| 369 | +
- rsp <- c(.ref_group[[.var]], df[[.var]])+ #' |
|||
| 79 | -2x | +|||
| 370 | +
- grp <- factor(+ #' @return |
|||
| 80 | -2x | +|||
| 371 | +
- rep(+ #' * If `x` is of class `logical`, returns a `list` with named `numeric` items: |
|||
| 81 | -2x | +|||
| 372 | +
- c("ref", "Not-ref"),
+ #' * `n`: The [length()] of `x` (possibly after removing `NA`s). |
|||
| 82 | -2x | +|||
| 373 | +
- c(nrow(.ref_group), nrow(df))+ #' * `count`: Count of `TRUE` in `x`. |
|||
| 83 | +374 |
- ),+ #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the |
||
| 84 | -2x | +|||
| 375 | +
- levels = c("ref", "Not-ref")
+ #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here. |
|||
| 85 | +376 |
- )+ #' |
||
| 86 | +377 |
-
+ #' @method s_summary logical |
||
| 87 | -2x | +|||
| 378 | +
- if (!is.null(variables$strata)) {
+ #' |
|||
| 88 | -1x | +|||
| 379 | +
- strata_colnames <- variables$strata+ #' @examples |
|||
| 89 | -1x | +|||
| 380 | +
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ #' # `s_summary.logical` |
|||
| 90 | -1x | +|||
| 381 | +
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ #' |
|||
| 91 | +382 |
-
+ #' ## Basic usage: |
||
| 92 | -1x | +|||
| 383 | +
- assert_df_with_variables(df, strata_vars)+ #' s_summary(c(TRUE, FALSE, TRUE, TRUE)) |
|||
| 93 | -1x | +|||
| 384 | +
- assert_df_with_variables(.ref_group, strata_vars)+ #' |
|||
| 94 | +385 |
-
+ #' # Empty factor returns zero-filled items. |
||
| 95 | +386 |
- # Merging interaction strata for reference group rows data and remaining+ #' s_summary(as.logical(c())) |
||
| 96 | -1x | +|||
| 387 | +
- strata <- c(+ #' |
|||
| 97 | -1x | +|||
| 388 | +
- interaction(.ref_group[strata_colnames]),+ #' ## Management of NA values. |
|||
| 98 | -1x | +|||
| 389 | +
- interaction(df[strata_colnames])+ #' x <- c(NA, TRUE, FALSE) |
|||
| 99 | +390 |
- )+ #' s_summary(x, na.rm = TRUE) |
||
| 100 | -1x | +|||
| 391 | +
- strata <- as.factor(strata)+ #' s_summary(x, na.rm = FALSE) |
|||
| 101 | +392 |
- }+ #' |
||
| 102 | +393 |
-
+ #' ## Different denominators. |
||
| 103 | +394 |
- # Defining the std way to calculate weights for strat_newcombe+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
||
| 104 | -2x | +|||
| 395 | +
- if (!is.null(variables$weights_method)) {
+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
|||
| 105 | -! | +|||
| 396 | +
- weights_method <- variables$weights_method+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
|||
| 106 | +397 |
- } else {
+ #' |
||
| 107 | -2x | +|||
| 398 | +
- weights_method <- "cmh"+ #' @export |
|||
| 108 | +399 |
- }+ s_summary.logical <- function(x, |
||
| 109 | +400 |
-
+ na.rm = TRUE, # nolint |
||
| 110 | -2x | +|||
| 401 | +
- y <- switch(method,+ denom = c("n", "N_col", "N_row"),
|
|||
| 111 | -2x | +|||
| 402 | +
- "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),+ .N_row, # nolint |
|||
| 112 | -2x | +|||
| 403 | +
- "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),+ .N_col, # nolint |
|||
| 113 | -2x | +|||
| 404 | +
- "ha" = prop_diff_ha(rsp, grp, conf_level),+ ...) {
|
|||
| 114 | -2x | +405 | +196x |
- "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),+ if (na.rm) x <- x[!is.na(x)] |
| 115 | -2x | +406 | +198x |
- "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),+ y <- list() |
| 116 | -2x | +407 | +198x |
- "strat_newcombe" = prop_diff_strat_nc(rsp,+ y$n <- length(x) |
| 117 | -2x | +408 | +198x |
- grp,+ count <- sum(x, na.rm = TRUE) |
| 118 | -2x | +409 | +198x |
- strata,+ denom <- match.arg(denom) %>% |
| 119 | -2x | +410 | +198x |
- weights_method,+ switch( |
| 120 | -2x | +411 | +198x |
- conf_level,+ n = length(x), |
| 121 | -2x | -
- correct = FALSE- |
- ||
| 122 | -+ | 412 | +198x |
- ),+ N_row = .N_row, |
| 123 | -2x | +413 | +198x |
- "strat_newcombecc" = prop_diff_strat_nc(rsp,+ N_col = .N_col |
| 124 | -2x | +|||
| 414 | +
- grp,+ ) |
|||
| 125 | -2x | +415 | +198x |
- strata,+ y$count <- count |
| 126 | -2x | +416 | +198x |
- weights_method,+ y$count_fraction <- c(count, ifelse(denom > 0, count / denom, 0)) |
| 127 | -2x | +417 | +198x |
- conf_level,+ y$n_blq <- 0L |
| 128 | -2x | +418 | +198x |
- correct = TRUE+ y |
| 129 | +419 |
- ),+ } |
||
| 130 | -2x | +|||
| 420 | +
- "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
+
|
|||
| 131 | +421 |
- )+ #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and |
||
| 132 | +422 |
-
+ #' `compare_vars()` and as `cfun` in `summarize_colvars()`. |
||
| 133 | -2x | +|||
| 423 | +
- y$diff <- y$diff * 100+ #' |
|||
| 134 | -2x | +|||
| 424 | +
- y$diff_ci <- y$diff_ci * 100+ #' @param compare (`flag`)\cr whether comparison statistics should be analyzed instead of summary statistics |
|||
| 135 | +425 |
- }+ #' (`compare = TRUE` adds `pval` statistic comparing against reference group). |
||
| 136 | +426 |
-
+ #' |
||
| 137 | -2x | +|||
| 427 | +
- attr(y$diff, "label") <- "Difference in Response rate (%)"+ #' @return |
|||
| 138 | -2x | +|||
| 428 | +
- attr(y$diff_ci, "label") <- d_proportion_diff(+ #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 139 | -2x | +|||
| 429 | +
- conf_level, method,+ #' |
|||
| 140 | -2x | +|||
| 430 | +
- long = FALSE+ #' @note |
|||
| 141 | +431 |
- )+ #' * To use for comparison (with additional p-value statistic), parameter `compare` must be set to `TRUE`. |
||
| 142 | +432 |
-
+ #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is. |
||
| 143 | -2x | +|||
| 433 | +
- y+ #' |
|||
| 144 | +434 |
- }+ #' @examples |
||
| 145 | +435 |
-
+ #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
|
||
| 146 | +436 |
- #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.+ #' a_summary( |
||
| 147 | +437 |
- #'+ #' factor(c("a", "a", "b", "c", "a")),
|
||
| 148 | +438 |
- #' @return+ #' .ref_group = factor(c("a", "a", "b", "c")), compare = TRUE
|
||
| 149 | +439 |
- #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' ) |
||
| 150 | +440 |
#' |
||
| 151 | +441 |
- #' @examples+ #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
|
||
| 152 | +442 |
- #' a_proportion_diff(+ #' a_summary( |
||
| 153 | +443 |
- #' df = subset(dta, grp == "A"),+ #' c("A", "B", "A", "C"),
|
||
| 154 | +444 |
- #' .var = "rsp",+ #' .ref_group = c("B", "A", "C"), .var = "x", compare = TRUE, verbose = FALSE
|
||
| 155 | +445 |
- #' .ref_group = subset(dta, grp == "B"),+ #' ) |
||
| 156 | +446 |
- #' .in_ref_col = FALSE,+ #' |
||
| 157 | +447 |
- #' conf_level = 0.90,+ #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10) |
||
| 158 | +448 |
- #' method = "ha"+ #' a_summary( |
||
| 159 | +449 |
- #' )+ #' c(TRUE, FALSE, FALSE, TRUE, TRUE), |
||
| 160 | +450 |
- #'+ #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare = TRUE |
||
| 161 | +451 |
- #' @export+ #' ) |
||
| 162 | +452 |
- a_proportion_diff <- make_afun(+ #' |
||
| 163 | +453 |
- s_proportion_diff,+ #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla") |
||
| 164 | +454 |
- .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),+ #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE) |
||
| 165 | +455 |
- .indent_mods = c(diff = 0L, diff_ci = 1L)+ #' |
||
| 166 | +456 |
- )+ #' @export |
||
| 167 | +457 |
-
+ a_summary <- function(x, |
||
| 168 | +458 |
- #' @describeIn prop_diff Layout-creating function which can take statistics function arguments+ .N_col, # nolint |
||
| 169 | +459 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ .N_row, # nolint |
||
| 170 | +460 |
- #'+ .var = NULL, |
||
| 171 | +461 |
- #' @return+ .df_row = NULL, |
||
| 172 | +462 |
- #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ .ref_group = NULL, |
||
| 173 | +463 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ .in_ref_col = FALSE, |
||
| 174 | +464 |
- #' the statistics from `s_proportion_diff()` to the table layout.+ compare = FALSE, |
||
| 175 | +465 |
- #'+ .stats = NULL, |
||
| 176 | +466 |
- #' @examples+ .formats = NULL, |
||
| 177 | +467 |
- #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.+ .labels = NULL, |
||
| 178 | +468 |
- #' nex <- 100 # Number of example rows+ .indent_mods = NULL, |
||
| 179 | +469 |
- #' dta <- data.frame(+ na.rm = TRUE, # nolint |
||
| 180 | +470 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ na_str = default_na_str(), |
||
| 181 | +471 |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ ...) {
|
||
| 182 | -+ | |||
| 472 | +324x |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ extra_args <- list(...) |
||
| 183 | -+ | |||
| 473 | +324x |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ if (is.numeric(x)) {
|
||
| 184 | -+ | |||
| 474 | +86x |
- #' stringsAsFactors = TRUE+ type <- "numeric" |
||
| 185 | -+ | |||
| 475 | +86x |
- #' )+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
|
||
| 186 | -+ | |||
| 476 | +10x |
- #'+ .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
|
||
| 187 | +477 |
- #' l <- basic_table() %>%+ } |
||
| 188 | +478 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ } else {
|
||
| 189 | -+ | |||
| 479 | +238x |
- #' estimate_proportion_diff(+ type <- "counts" |
||
| 190 | -+ | |||
| 480 | +238x |
- #' vars = "rsp",+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
|
||
| 191 | -+ | |||
| 481 | +9x |
- #' conf_level = 0.90,+ .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
|
||
| 192 | +482 |
- #' method = "ha"+ } |
||
| 193 | +483 |
- #' )+ } |
||
| 194 | +484 |
- #'+ |
||
| 195 | +485 |
- #' build_table(l, df = dta)+ # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`) |
||
| 196 | -+ | |||
| 486 | +! |
- #'+ if (any(is.na(.df_row[[.var]])) && !any(is.na(x)) && !na.rm) levels(x) <- c(levels(x), "fill-na-level") |
||
| 197 | +487 |
- #' @export+ |
||
| 198 | -+ | |||
| 488 | +324x |
- #' @order 2+ x_stats <- if (!compare) {
|
||
| 199 | -+ | |||
| 489 | +300x |
- estimate_proportion_diff <- function(lyt,+ s_summary(x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, ...) |
||
| 200 | +490 |
- vars,+ } else {
|
||
| 201 | -+ | |||
| 491 | +24x |
- variables = list(strata = NULL),+ s_compare( |
||
| 202 | -+ | |||
| 492 | +24x |
- conf_level = 0.95,+ x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, .ref_group = .ref_group, .in_ref_col = .in_ref_col, ... |
||
| 203 | +493 |
- method = c(+ ) |
||
| 204 | +494 |
- "waldcc", "wald", "cmh",+ } |
||
| 205 | +495 |
- "ha", "newcombe", "newcombecc",+ |
||
| 206 | +496 |
- "strat_newcombe", "strat_newcombecc"+ # Fill in with formatting defaults if needed |
||
| 207 | -+ | |||
| 497 | +324x |
- ),+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
||
| 208 | -+ | |||
| 498 | +324x |
- weights_method = "cmh",+ .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare) |
||
| 209 | -+ | |||
| 499 | +324x |
- na_str = default_na_str(),+ .formats <- get_formats_from_stats(.stats, .formats) |
||
| 210 | -+ | |||
| 500 | +324x |
- nested = TRUE,+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
||
| 211 | +501 |
- ...,+ |
||
| 212 | -+ | |||
| 502 | +324x |
- var_labels = vars,+ lbls <- get_labels_from_stats(.stats, .labels) |
||
| 213 | +503 |
- show_labels = "hidden",+ # Check for custom labels from control_analyze_vars |
||
| 214 | -+ | |||
| 504 | +324x |
- table_names = vars,+ .labels <- if ("control" %in% names(extra_args)) {
|
||
| 215 | -+ | |||
| 505 | +1x |
- .stats = NULL,+ lbls %>% labels_use_control(extra_args[["control"]], .labels) |
||
| 216 | +506 |
- .formats = NULL,+ } else {
+ |
+ ||
| 507 | +323x | +
+ lbls |
||
| 217 | +508 |
- .labels = NULL,+ } |
||
| 218 | +509 |
- .indent_mods = NULL) {
+
|
||
| 219 | -4x | +510 | +11x |
- extra_args <- list(+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
| 220 | -4x | +511 | +324x |
- variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ...+ x_stats <- x_stats[.stats] |
| 221 | +512 |
- )+ |
||
| 222 | -+ | |||
| 513 | +324x |
-
+ if (is.factor(x) || is.character(x)) {
|
||
| 223 | -4x | +|||
| 514 | +
- afun <- make_afun(+ # Ungroup statistics with values for each level of x |
|||
| 224 | -4x | +515 | +234x |
- a_proportion_diff,+ x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods) |
| 225 | -4x | +516 | +234x |
- .stats = .stats,+ x_stats <- x_ungrp[["x"]] |
| 226 | -4x | +517 | +234x |
- .formats = .formats,+ .formats <- x_ungrp[[".formats"]] |
| 227 | -4x | +518 | +234x |
- .labels = .labels,+ .labels <- gsub("fill-na-level", "NA", x_ungrp[[".labels"]])
|
| 228 | -4x | +519 | +234x |
- .indent_mods = .indent_mods+ .indent_mods <- x_ungrp[[".indent_mods"]] |
| 229 | +520 |
- )+ } |
||
| 230 | +521 | |||
| 231 | -4x | +|||
| 522 | +
- analyze(+ # Auto format handling |
|||
| 232 | -4x | +523 | +324x |
- lyt,+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
| 233 | -4x | +|||
| 524 | +
- vars,+ |
|||
| 234 | -4x | +525 | +324x |
- afun = afun,+ in_rows( |
| 235 | -4x | +526 | +324x |
- var_labels = var_labels,+ .list = x_stats, |
| 236 | -4x | +527 | +324x |
- na_str = na_str,+ .formats = .formats, |
| 237 | -4x | +528 | +324x |
- nested = nested,+ .names = names(.labels), |
| 238 | -4x | +529 | +324x |
- extra_args = extra_args,+ .labels = .labels, |
| 239 | -4x | +530 | +324x |
- show_labels = show_labels,+ .indent_mods = .indent_mods, |
| 240 | -4x | +531 | +324x |
- table_names = table_names+ .format_na_strs = na_str |
| 241 | +532 |
) |
||
| 242 | +533 |
} |
||
| 243 | +534 | |||
| 244 | +535 |
- #' Check proportion difference arguments+ #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments |
||
| 245 | +536 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 246 | +537 |
- #' Verifies that and/or convert arguments into valid values to be used in the+ #' |
||
| 247 | +538 |
- #' estimation of difference in responder proportions.+ #' @param ... arguments passed to `s_summary()`. |
||
| 248 | +539 |
- #'+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 249 | +540 |
- #' @inheritParams prop_diff+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 250 | +541 |
- #' @inheritParams prop_diff_wald+ #' for that statistic's row label. |
||
| 251 | +542 |
#' |
||
| 252 | +543 |
- #' @keywords internal+ #' @return |
||
| 253 | +544 |
- check_diff_prop_ci <- function(rsp,+ #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions, |
||
| 254 | +545 |
- grp,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 255 | +546 |
- strata = NULL,+ #' the statistics from `s_summary()` to the table layout. |
||
| 256 | +547 |
- conf_level,+ #' |
||
| 257 | +548 |
- correct = NULL) {
- |
- ||
| 258 | -26x | -
- checkmate::assert_logical(rsp, any.missing = FALSE)- |
- ||
| 259 | -26x | -
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)- |
- ||
| 260 | -26x | -
- checkmate::assert_number(conf_level, lower = 0, upper = 1)- |
- ||
| 261 | -26x | -
- checkmate::assert_flag(correct, null.ok = TRUE)+ #' @examples |
||
| 262 | +549 | - - | -||
| 263 | -26x | -
- if (!is.null(strata)) {
- |
- ||
| 264 | -12x | -
- checkmate::assert_factor(strata, len = length(rsp))+ #' ## Fabricated dataset. |
||
| 265 | +550 |
- }+ #' dta_test <- data.frame( |
||
| 266 | +551 |
-
+ #' USUBJID = rep(1:6, each = 3), |
||
| 267 | -26x | +|||
| 552 | +
- invisible()+ #' PARAMCD = rep("lab", 6 * 3),
|
|||
| 268 | +553 |
- }+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 269 | +554 |
-
+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 270 | +555 |
- #' Description of method used for proportion comparison+ #' AVAL = c(9:1, rep(NA, 9)) |
||
| 271 | +556 |
- #'+ #' ) |
||
| 272 | +557 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 273 | +558 |
- #'+ #' # `analyze_vars()` in `rtables` pipelines |
||
| 274 | +559 |
- #' This is an auxiliary function that describes the analysis in+ #' ## Default output within a `rtables` pipeline. |
||
| 275 | +560 |
- #' [s_proportion_diff()].+ #' l <- basic_table() %>% |
||
| 276 | +561 |
- #'+ #' split_cols_by(var = "ARM") %>% |
||
| 277 | +562 |
- #' @inheritParams s_proportion_diff+ #' split_rows_by(var = "AVISIT") %>% |
||
| 278 | +563 |
- #' @param long (`flag`)\cr whether a long (`TRUE`) or a short (`FALSE`, default) description is required.+ #' analyze_vars(vars = "AVAL") |
||
| 279 | +564 |
#' |
||
| 280 | +565 |
- #' @return A `string` describing the analysis.+ #' build_table(l, df = dta_test) |
||
| 281 | +566 |
#' |
||
| 282 | +567 |
- #' @seealso [prop_diff]+ #' ## Select and format statistics output. |
||
| 283 | +568 |
- #'+ #' l <- basic_table() %>% |
||
| 284 | +569 |
- #' @export+ #' split_cols_by(var = "ARM") %>% |
||
| 285 | +570 |
- d_proportion_diff <- function(conf_level,+ #' split_rows_by(var = "AVISIT") %>% |
||
| 286 | +571 |
- method,+ #' analyze_vars( |
||
| 287 | +572 |
- long = FALSE) {
- |
- ||
| 288 | -11x | -
- label <- paste0(conf_level * 100, "% CI")- |
- ||
| 289 | -11x | -
- if (long) {
- |
- ||
| 290 | -! | -
- label <- paste(- |
- ||
| 291 | -! | -
- label,- |
- ||
| 292 | -! | -
- ifelse(- |
- ||
| 293 | -! | -
- method == "cmh",+ #' vars = "AVAL", |
||
| 294 | -! | +|||
| 573 | +
- "for adjusted difference",+ #' .stats = c("n", "mean_sd", "quantiles"),
|
|||
| 295 | -! | +|||
| 574 | +
- "for difference"+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
|
|||
| 296 | +575 |
- )+ #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
|
||
| 297 | +576 |
- )+ #' ) |
||
| 298 | +577 |
- }+ #' |
||
| 299 | +578 |
-
+ #' build_table(l, df = dta_test) |
||
| 300 | -11x | +|||
| 579 | +
- method_part <- switch(method,+ #' |
|||
| 301 | -11x | +|||
| 580 | +
- "cmh" = "CMH, without correction",+ #' ## Use arguments interpreted by `s_summary`. |
|||
| 302 | -11x | +|||
| 581 | +
- "waldcc" = "Wald, with correction",+ #' l <- basic_table() %>% |
|||
| 303 | -11x | +|||
| 582 | +
- "wald" = "Wald, without correction",+ #' split_cols_by(var = "ARM") %>% |
|||
| 304 | -11x | +|||
| 583 | +
- "ha" = "Anderson-Hauck",+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 305 | -11x | +|||
| 584 | +
- "newcombe" = "Newcombe, without correction",+ #' analyze_vars(vars = "AVAL", na.rm = FALSE) |
|||
| 306 | -11x | +|||
| 585 | +
- "newcombecc" = "Newcombe, with correction",+ #' |
|||
| 307 | -11x | +|||
| 586 | +
- "strat_newcombe" = "Stratified Newcombe, without correction",+ #' build_table(l, df = dta_test) |
|||
| 308 | -11x | +|||
| 587 | +
- "strat_newcombecc" = "Stratified Newcombe, with correction",+ #' |
|||
| 309 | -11x | +|||
| 588 | +
- stop(paste(method, "does not have a description"))+ #' ## Handle `NA` levels first when summarizing factors. |
|||
| 310 | +589 |
- )+ #' dta_test$AVISIT <- NA_character_ |
||
| 311 | -11x | +|||
| 590 | +
- paste0(label, " (", method_part, ")")
+ #' dta_test <- df_explicit_na(dta_test) |
|||
| 312 | +591 |
- }+ #' l <- basic_table() %>% |
||
| 313 | +592 |
-
+ #' split_cols_by(var = "ARM") %>% |
||
| 314 | +593 |
- #' Helper functions to calculate proportion difference+ #' analyze_vars(vars = "AVISIT", na.rm = FALSE) |
||
| 315 | +594 |
#' |
||
| 316 | +595 |
- #' @description `r lifecycle::badge("stable")`
+ #' build_table(l, df = dta_test) |
||
| 317 | +596 |
#' |
||
| 318 | +597 |
- #' @inheritParams argument_convention+ #' # auto format |
||
| 319 | +598 |
- #' @inheritParams prop_diff+ #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
|
||
| 320 | +599 |
- #' @param grp (`factor`)\cr vector assigning observations to one out of two groups+ #' basic_table() %>% |
||
| 321 | +600 |
- #' (e.g. reference and treatment group).+ #' analyze_vars( |
||
| 322 | +601 |
- #'+ #' vars = "VAR", |
||
| 323 | +602 |
- #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci`+ #' .stats = c("n", "mean", "mean_sd", "range"),
|
||
| 324 | +603 |
- #' (proportion difference confidence interval).+ #' .formats = c("mean_sd" = "auto", "range" = "auto")
|
||
| 325 | +604 |
- #'+ #' ) %>% |
||
| 326 | +605 |
- #' @seealso [prop_diff()] for implementation of these helper functions.+ #' build_table(dt) |
||
| 327 | +606 |
#' |
||
| 328 | +607 |
- #' @name h_prop_diff+ #' @export |
||
| 329 | +608 |
- NULL+ #' @order 2 |
||
| 330 | +609 |
-
+ analyze_vars <- function(lyt, |
||
| 331 | +610 |
- #' @describeIn h_prop_diff The Wald interval follows the usual textbook+ vars, |
||
| 332 | +611 |
- #' definition for a single proportion confidence interval using the normal+ var_labels = vars, |
||
| 333 | +612 |
- #' approximation. It is possible to include a continuity correction for Wald's+ na_str = default_na_str(), |
||
| 334 | +613 |
- #' interval.+ nested = TRUE, |
||
| 335 | +614 |
- #'+ ..., |
||
| 336 | +615 |
- #' @param correct (`flag`)\cr whether to include the continuity correction. For further+ na.rm = TRUE, # nolint |
||
| 337 | +616 |
- #' information, see [stats::prop.test()].+ show_labels = "default", |
||
| 338 | +617 |
- #'+ table_names = vars, |
||
| 339 | +618 |
- #' @examples+ section_div = NA_character_, |
||
| 340 | +619 |
- #' # Wald confidence interval+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
||
| 341 | +620 |
- #' set.seed(2)+ .formats = NULL, |
||
| 342 | +621 |
- #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)+ .labels = NULL, |
||
| 343 | +622 |
- #' grp <- factor(c(rep("A", 10), rep("B", 10)))
+ .indent_mods = NULL) {
|
||
| 344 | -+ | |||
| 623 | +30x |
- #'+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...) |
||
| 345 | -+ | |||
| 624 | +4x |
- #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
||
| 346 | -+ | |||
| 625 | +2x |
- #'+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
||
| 347 | -+ | |||
| 626 | +! |
- #' @export+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
||
| 348 | +627 |
- prop_diff_wald <- function(rsp,+ |
||
| 349 | -+ | |||
| 628 | +30x |
- grp,+ analyze( |
||
| 350 | -+ | |||
| 629 | +30x |
- conf_level = 0.95,+ lyt = lyt, |
||
| 351 | -+ | |||
| 630 | +30x |
- correct = FALSE) {
+ vars = vars, |
||
| 352 | -8x | +631 | +30x |
- if (isTRUE(correct)) {
+ var_labels = var_labels, |
| 353 | -5x | +632 | +30x |
- mthd <- "waldcc"+ afun = a_summary, |
| 354 | -+ | |||
| 633 | +30x |
- } else {
+ na_str = na_str, |
||
| 355 | -3x | +634 | +30x |
- mthd <- "wald"+ nested = nested, |
| 356 | -+ | |||
| 635 | +30x |
- }+ extra_args = extra_args, |
||
| 357 | -8x | +636 | +30x |
- grp <- as_factor_keep_attributes(grp)+ inclNAs = TRUE, |
| 358 | -8x | +637 | +30x |
- check_diff_prop_ci(+ show_labels = show_labels, |
| 359 | -8x | +638 | +30x |
- rsp = rsp, grp = grp, conf_level = conf_level, correct = correct+ table_names = table_names,+ |
+
| 639 | +30x | +
+ section_div = section_div |
||
| 360 | +640 |
) |
||
| 361 | +641 |
-
+ } |
| 362 | +1 |
- # check if binary response is coded as logical+ #' Count patients with abnormal range values |
||
| 363 | -8x | +|||
| 2 | +
- checkmate::assert_logical(rsp, any.missing = FALSE)+ #' |
|||
| 364 | -8x | +|||
| 3 | +
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 365 | +4 |
-
+ #' |
||
| 366 | -8x | +|||
| 5 | +
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ #' The analyze function [count_abnormal()] creates a layout element to count patients with abnormal analysis range |
|||
| 367 | +6 |
- # x1 and n1 are non-reference groups.+ #' values in each direction. |
||
| 368 | -8x | +|||
| 7 | +
- diff_ci <- desctools_binom(+ #' |
|||
| 369 | -8x | +|||
| 8 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ #' This function analyzes primary analysis variable `var` which indicates abnormal range results. |
|||
| 370 | -8x | +|||
| 9 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ #' Additional analysis variables that can be supplied as a list via the `variables` parameter are |
|||
| 371 | -8x | +|||
| 10 | +
- conf.level = conf_level,+ #' `id` (defaults to `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` |
|||
| 372 | -8x | +|||
| 11 | +
- method = mthd+ #' (defaults to `BNRIND`), a variable to indicate baseline reference ranges. |
|||
| 373 | +12 |
- )+ #' |
||
| 374 | +13 |
-
+ #' For each direction specified via the `abnormal` parameter (e.g. High or Low), a fraction of |
||
| 375 | -8x | +|||
| 14 | +
- list(+ #' patient counts is returned, with numerator and denominator calculated as follows: |
|||
| 376 | -8x | +|||
| 15 | +
- "diff" = unname(diff_ci[, "est"]),+ #' * `num`: The number of patients with this abnormality recorded while on treatment. |
|||
| 377 | -8x | +|||
| 16 | +
- "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
+ #' * `denom`: The total number of patients with at least one post-baseline assessment. |
|||
| 378 | +17 |
- )+ #' |
||
| 379 | +18 |
- }+ #' This function assumes that `df` has been filtered to only include post-baseline records. |
||
| 380 | +19 |
-
+ #' |
||
| 381 | +20 |
- #' @describeIn h_prop_diff Anderson-Hauck confidence interval.+ #' @inheritParams argument_convention |
||
| 382 | +21 |
- #'+ #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to |
||
| 383 | +22 |
- #' @examples+ #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list, |
||
| 384 | +23 |
- #' # Anderson-Hauck confidence interval+ #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
|
||
| 385 | +24 |
- #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.+ #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality |
||
| 386 | +25 |
- #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)+ #' from numerator and denominator. |
||
| 387 | +26 |
- #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 388 | +27 |
#' |
||
| 389 | +28 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)+ #' Options are: ``r shQuote(get_stats("abnormal"))``
|
||
| 390 | +29 |
#' |
||
| 391 | +30 |
- #' ## Edge case: Same proportion of response in A and B.+ #' @note |
||
| 392 | +31 |
- #' rsp <- c(TRUE, FALSE, TRUE, FALSE)+ #' * `count_abnormal()` only considers a single variable that contains multiple abnormal levels. |
||
| 393 | +32 |
- #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ #' * `df` should be filtered to only include post-baseline records. |
||
| 394 | +33 |
- #'+ #' * The denominator includes patients that may have other abnormal levels at baseline, |
||
| 395 | +34 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)+ #' and patients missing baseline records. Patients with these abnormalities at |
||
| 396 | +35 |
- #'+ #' baseline can be optionally excluded from numerator and denominator via the |
||
| 397 | +36 |
- #' @export+ #' `exclude_base_abn` parameter. |
||
| 398 | +37 |
- prop_diff_ha <- function(rsp,+ #' |
||
| 399 | +38 |
- grp,+ #' @name abnormal |
||
| 400 | +39 |
- conf_level) {
+ #' @include formatting_functions.R |
||
| 401 | -4x | +|||
| 40 | +
- grp <- as_factor_keep_attributes(grp)+ #' @order 1 |
|||
| 402 | -4x | +|||
| 41 | +
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ NULL |
|||
| 403 | +42 | |||
| 404 | -4x | +|||
| 43 | +
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ #' @describeIn abnormal Statistics function which counts patients with abnormal range values |
|||
| 405 | +44 |
- # x1 and n1 are non-reference groups.+ #' for a single `abnormal` level. |
||
| 406 | -4x | +|||
| 45 | +
- ci <- desctools_binom(+ #' |
|||
| 407 | -4x | +|||
| 46 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ #' @return |
|||
| 408 | -4x | +|||
| 47 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients. |
|||
| 409 | -4x | +|||
| 48 | +
- conf.level = conf_level,+ #' |
|||
| 410 | -4x | +|||
| 49 | +
- method = "ha"+ #' @keywords internal |
|||
| 411 | +50 |
- )+ s_count_abnormal <- function(df, |
||
| 412 | -4x | +|||
| 51 | +
- list(+ .var, |
|||
| 413 | -4x | +|||
| 52 | +
- "diff" = unname(ci[, "est"]),+ abnormal = list(Low = "LOW", High = "HIGH"), |
|||
| 414 | -4x | +|||
| 53 | +
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
|||
| 415 | +54 |
- )+ exclude_base_abn = FALSE) {
|
||
| 416 | -+ | |||
| 55 | +4x |
- }+ checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE) |
||
| 417 | -+ | |||
| 56 | +4x |
-
+ checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]]))) |
||
| 418 | -+ | |||
| 57 | +4x |
- #' @describeIn h_prop_diff Newcombe confidence interval. It is based on+ checkmate::assert_factor(df[[.var]]) |
||
| 419 | -+ | |||
| 58 | +4x |
- #' the Wilson score confidence interval for a single binomial proportion.+ checkmate::assert_flag(exclude_base_abn) |
||
| 420 | -+ | |||
| 59 | +4x |
- #'+ assert_df_with_variables(df, c(range = .var, variables)) |
||
| 421 | -+ | |||
| 60 | +4x |
- #' @examples+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
||
| 422 | -+ | |||
| 61 | +4x |
- #' # Newcombe confidence interval+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
||
| 423 | +62 |
- #'+ |
||
| 424 | -+ | |||
| 63 | +4x |
- #' set.seed(1)+ count_abnormal_single <- function(abn_name, abn) {
|
||
| 425 | +64 |
- #' rsp <- c(+ # Patients in the denominator fulfill: |
||
| 426 | +65 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),+ # - have at least one post-baseline visit |
||
| 427 | +66 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)+ # - their baseline must not be abnormal if `exclude_base_abn`. |
||
| 428 | -+ | |||
| 67 | +8x |
- #' )+ if (exclude_base_abn) {
|
||
| 429 | -+ | |||
| 68 | +4x |
- #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
+ denom_select <- !(df[[variables$baseline]] %in% abn) |
||
| 430 | +69 |
- #' table(rsp, grp)+ } else {
|
||
| 431 | -+ | |||
| 70 | +4x |
- #'+ denom_select <- TRUE |
||
| 432 | +71 |
- #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)+ } |
||
| 433 | -+ | |||
| 72 | +8x |
- #'+ denom <- length(unique(df[denom_select, variables$id, drop = TRUE])) |
||
| 434 | +73 |
- #' @export+ |
||
| 435 | +74 |
- prop_diff_nc <- function(rsp,+ # Patients in the numerator fulfill: |
||
| 436 | +75 |
- grp,+ # - have at least one post-baseline visit with the required abnormality level |
||
| 437 | +76 |
- conf_level,+ # - are part of the denominator patients.+ |
+ ||
| 77 | +8x | +
+ num_select <- (df[[.var]] %in% abn) & denom_select+ |
+ ||
| 78 | +8x | +
+ num <- length(unique(df[num_select, variables$id, drop = TRUE])) |
||
| 438 | +79 |
- correct = FALSE) {
+
|
||
| 439 | -2x | +80 | +8x |
- if (isTRUE(correct)) {
+ formatters::with_label(c(num = num, denom = denom), abn_name) |
| 440 | -! | +|||
| 81 | +
- mthd <- "scorecc"+ } |
|||
| 441 | +82 |
- } else {
+
|
||
| 442 | -2x | +|||
| 83 | +
- mthd <- "score"+ # This will define the abnormal levels theoretically possible for a specific lab parameter |
|||
| 443 | +84 |
- }+ # within a split level of a layout. |
||
| 444 | -2x | +85 | +4x |
- grp <- as_factor_keep_attributes(grp)+ abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]])) |
| 445 | -2x | +86 | +4x |
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))] |
| 446 | +87 | |||
| 447 | -2x | +88 | +4x |
- p_grp <- tapply(rsp, grp, mean)+ result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE) |
| 448 | -2x | +89 | +4x |
- diff_p <- unname(diff(p_grp))+ result <- list(fraction = result) |
| 449 | -2x | +90 | +4x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ result |
| 450 | -2x | +|||
| 91 | +
- ci <- desctools_binom(+ } |
|||
| 451 | +92 |
- # x1 and n1 are non-reference groups.+ |
||
| 452 | -2x | +|||
| 93 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`. |
|||
| 453 | -2x | +|||
| 94 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ #' |
|||
| 454 | -2x | +|||
| 95 | +
- conf.level = conf_level,+ #' @return |
|||
| 455 | -2x | +|||
| 96 | +
- method = mthd+ #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 456 | +97 |
- )+ #' |
||
| 457 | -2x | +|||
| 98 | +
- list(+ #' @keywords internal |
|||
| 458 | -2x | +|||
| 99 | +
- "diff" = unname(ci[, "est"]),+ a_count_abnormal <- make_afun( |
|||
| 459 | -2x | +|||
| 100 | +
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ s_count_abnormal, |
|||
| 460 | +101 |
- )+ .formats = c(fraction = format_fraction) |
||
| 461 | +102 |
- }+ ) |
||
| 462 | +103 | |||
| 463 | +104 |
- #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in+ #' @describeIn abnormal Layout-creating function which can take statistics function arguments |
||
| 464 | +105 |
- #' response rates between the experimental treatment group and the control treatment group, adjusted+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 465 | +106 |
- #' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights. For the CMH chi-squared+ #' |
||
| 466 | +107 |
- #' test, use [stats::mantelhaen.test()].+ #' @return |
||
| 467 | +108 |
- #'+ #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions, |
||
| 468 | +109 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 469 | +110 | ++ |
+ #' the statistics from `s_count_abnormal()` to the table layout.+ |
+ |
| 111 |
#' |
|||
| 470 | +112 |
#' @examples |
||
| 471 | +113 |
- #' # Cochran-Mantel-Haenszel confidence interval+ #' library(dplyr) |
||
| 472 | +114 |
#' |
||
| 473 | +115 |
- #' set.seed(2)+ #' df <- data.frame( |
||
| 474 | +116 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ #' USUBJID = as.character(c(1, 1, 2, 2)), |
||
| 475 | +117 |
- #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
+ #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 476 | +118 |
- #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
+ #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 477 | +119 |
- #' strata_data <- data.frame(+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 478 | +120 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' stringsAsFactors = FALSE |
||
| 479 | +121 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' ) |
||
| 480 | +122 |
- #' stringsAsFactors = TRUE+ #' |
||
| 481 | +123 |
- #' )+ #' # Select only post-baseline records. |
||
| 482 | +124 |
- #'+ #' df <- df %>% |
||
| 483 | +125 |
- #' prop_diff_cmh(+ #' filter(ONTRTFL == "Y") |
||
| 484 | +126 |
- #' rsp = rsp, grp = grp, strata = interaction(strata_data),+ #' |
||
| 485 | +127 |
- #' conf_level = 0.90+ #' # Layout creating function. |
||
| 486 | +128 |
- #' )+ #' basic_table() %>% |
||
| 487 | +129 |
- #'+ #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>% |
||
| 488 | +130 |
- #' @export+ #' build_table(df) |
||
| 489 | +131 |
- prop_diff_cmh <- function(rsp,+ #' |
||
| 490 | +132 |
- grp,+ #' # Passing of statistics function and formatting arguments. |
||
| 491 | +133 |
- strata,+ #' df2 <- data.frame( |
||
| 492 | +134 |
- conf_level = 0.95) {
+ #' ID = as.character(c(1, 1, 2, 2)), |
||
| 493 | -8x | +|||
| 135 | +
- grp <- as_factor_keep_attributes(grp)+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
|||
| 494 | -8x | +|||
| 136 | +
- strata <- as_factor_keep_attributes(strata)+ #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
|||
| 495 | -8x | +|||
| 137 | +
- check_diff_prop_ci(+ #' ONTRTFL = c("", "Y", "", "Y"),
|
|||
| 496 | -8x | +|||
| 138 | +
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ #' stringsAsFactors = FALSE |
|||
| 497 | +139 |
- )+ #' ) |
||
| 498 | +140 |
-
+ #' |
||
| 499 | -8x | +|||
| 141 | +
- if (any(tapply(rsp, strata, length) < 5)) {
+ #' # Select only post-baseline records. |
|||
| 500 | -1x | +|||
| 142 | +
- warning("Less than 5 observations in some strata.")
+ #' df2 <- df2 %>% |
|||
| 501 | +143 |
- }+ #' filter(ONTRTFL == "Y") |
||
| 502 | +144 |
-
+ #' |
||
| 503 | +145 |
- # first dimension: FALSE, TRUE+ #' basic_table() %>% |
||
| 504 | +146 |
- # 2nd dimension: CONTROL, TX+ #' count_abnormal( |
||
| 505 | +147 |
- # 3rd dimension: levels of strata+ #' var = "RANGE", |
||
| 506 | +148 |
- # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records+ #' abnormal = list(low = "LOW", high = "HIGH"), |
||
| 507 | -8x | +|||
| 149 | +
- t_tbl <- table(+ #' variables = list(id = "ID", baseline = "BL_RANGE") |
|||
| 508 | -8x | +|||
| 150 | +
- factor(rsp, levels = c("FALSE", "TRUE")),
+ #' ) %>% |
|||
| 509 | -8x | +|||
| 151 | +
- grp,+ #' build_table(df2) |
|||
| 510 | -8x | +|||
| 152 | +
- strata+ #' |
|||
| 511 | +153 |
- )+ #' @export |
||
| 512 | -8x | +|||
| 154 | +
- n1 <- colSums(t_tbl[1:2, 1, ])+ #' @order 2 |
|||
| 513 | -8x | +|||
| 155 | +
- n2 <- colSums(t_tbl[1:2, 2, ])+ count_abnormal <- function(lyt, |
|||
| 514 | -8x | +|||
| 156 | +
- p1 <- t_tbl[2, 1, ] / n1+ var, |
|||
| 515 | -8x | +|||
| 157 | +
- p2 <- t_tbl[2, 2, ] / n2+ abnormal = list(Low = "LOW", High = "HIGH"), |
|||
| 516 | +158 |
- # CMH weights+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 517 | -8x | +|||
| 159 | +
- use_stratum <- (n1 > 0) & (n2 > 0)+ exclude_base_abn = FALSE, |
|||
| 518 | -8x | +|||
| 160 | +
- n1 <- n1[use_stratum]+ na_str = default_na_str(), |
|||
| 519 | -8x | +|||
| 161 | +
- n2 <- n2[use_stratum]+ nested = TRUE, |
|||
| 520 | -8x | +|||
| 162 | +
- p1 <- p1[use_stratum]+ ..., |
|||
| 521 | -8x | +|||
| 163 | +
- p2 <- p2[use_stratum]+ table_names = var, |
|||
| 522 | -8x | +|||
| 164 | +
- wt <- (n1 * n2 / (n1 + n2))+ .stats = NULL, |
|||
| 523 | -8x | +|||
| 165 | +
- wt_normalized <- wt / sum(wt)+ .formats = NULL, |
|||
| 524 | -8x | +|||
| 166 | +
- est1 <- sum(wt_normalized * p1)+ .labels = NULL, |
|||
| 525 | -8x | +|||
| 167 | +
- est2 <- sum(wt_normalized * p2)+ .indent_mods = NULL) {
|
|||
| 526 | -8x | +168 | +3x |
- estimate <- c(est1, est2)+ extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...) |
| 527 | -8x | +|||
| 169 | +
- names(estimate) <- levels(grp)+ |
|||
| 528 | -8x | +170 | +3x |
- se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))+ afun <- make_afun( |
| 529 | -8x | +171 | +3x |
- se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))+ a_count_abnormal, |
| 530 | -8x | +172 | +3x |
- z <- stats::qnorm((1 + conf_level) / 2)+ .stats = .stats, |
| 531 | -8x | +173 | +3x |
- err1 <- z * se1+ .formats = .formats, |
| 532 | -8x | +174 | +3x |
- err2 <- z * se2+ .labels = .labels, |
| 533 | -8x | +175 | +3x |
- ci1 <- c((est1 - err1), (est1 + err1))+ .indent_mods = .indent_mods, |
| 534 | -8x | +176 | +3x |
- ci2 <- c((est2 - err2), (est2 + err2))+ .ungroup_stats = "fraction" |
| 535 | -8x | +|||
| 177 | +
- estimate_ci <- list(ci1, ci2)+ ) |
|||
| 536 | -8x | +|||
| 178 | +
- names(estimate_ci) <- levels(grp)+ |
|||
| 537 | -8x | +179 | +3x |
- diff_est <- est2 - est1+ checkmate::assert_string(var) |
| 538 | -8x | +|||
| 180 | +
- se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))+ |
|||
| 539 | -8x | -
- diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)- |
- ||
| 540 | -+ | 181 | +3x |
-
+ analyze( |
| 541 | -8x | +182 | +3x |
- list(+ lyt = lyt, |
| 542 | -8x | +183 | +3x |
- prop = estimate,+ vars = var, |
| 543 | -8x | +184 | +3x |
- prop_ci = estimate_ci,+ afun = afun, |
| 544 | -8x | +185 | +3x |
- diff = diff_est,+ na_str = na_str, |
| 545 | -8x | +186 | +3x |
- diff_ci = diff_ci,+ nested = nested, |
| 546 | -8x | +187 | +3x |
- weights = wt_normalized,+ table_names = table_names, |
| 547 | -8x | +188 | +3x |
- n1 = n1,+ extra_args = extra_args, |
| 548 | -8x | +189 | +3x |
- n2 = n2+ show_labels = "hidden" |
| 549 | +190 |
) |
||
| 550 | +191 |
} |
| 551 | +1 |
-
+ #' Estimate proportions of each level of a variable |
||
| 552 | +2 |
- #' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval and difference in response+ #' |
||
| 553 | +3 |
- #' rates between the experimental treatment group and the control treatment group, adjusted for stratification+ #' @description `r lifecycle::badge("stable")`
|
||
| 554 | +4 |
- #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
+ #' |
||
| 555 | +5 |
- #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights+ #' The analyze & summarize function [estimate_multinomial_response()] creates a layout element to estimate the |
||
| 556 | +6 |
- #' (see [prop_diff_cmh()]).+ #' proportion and proportion confidence interval for each level of a factor variable. The primary analysis variable, |
||
| 557 | +7 |
- #'+ #' `var`, should be a factor variable, the values of which will be used as labels within the output table. |
||
| 558 | +8 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' |
||
| 559 | +9 |
- #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`+ #' @inheritParams argument_convention |
||
| 560 | +10 |
- #' and directs the way weights are estimated.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 561 | +11 |
#' |
||
| 562 | -- |
- #' @references- |
- ||
| 563 | +12 |
- #' \insertRef{Yan2010-jt}{tern}
+ #' Options are: ``r shQuote(get_stats("estimate_multinomial_response"))``
|
||
| 564 | +13 |
#' |
||
| 565 | +14 |
- #' @examples+ #' @seealso Relevant description function [d_onco_rsp_label()]. |
||
| 566 | +15 |
- #' # Stratified Newcombe confidence interval+ #' |
||
| 567 | +16 |
- #'+ #' @name estimate_multinomial_rsp |
||
| 568 | +17 |
- #' set.seed(2)+ #' @order 1 |
||
| 569 | +18 |
- #' data_set <- data.frame(+ NULL |
||
| 570 | +19 |
- #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE),+ |
||
| 571 | +20 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' Description of standard oncology response |
||
| 572 | +21 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' |
||
| 573 | +22 |
- #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 574 | +23 |
- #' stringsAsFactors = TRUE+ #' |
||
| 575 | +24 |
- #' )+ #' Describe the oncology response in a standard way. |
||
| 576 | +25 |
#' |
||
| 577 | +26 |
- #' prop_diff_strat_nc(+ #' @param x (`character`)\cr the standard oncology codes to be described. |
||
| 578 | +27 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ #' |
||
| 579 | +28 |
- #' weights_method = "cmh",+ #' @return Response labels. |
||
| 580 | +29 |
- #' conf_level = 0.90+ #' |
||
| 581 | +30 |
- #' )+ #' @seealso [estimate_multinomial_rsp()] |
||
| 582 | +31 |
#' |
||
| 583 | +32 |
- #' prop_diff_strat_nc(+ #' @examples |
||
| 584 | +33 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ #' d_onco_rsp_label( |
||
| 585 | +34 |
- #' weights_method = "wilson_h",+ #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
|
||
| 586 | +35 |
- #' conf_level = 0.90+ #' ) |
||
| 587 | +36 |
- #' )+ #' |
||
| 588 | +37 |
- #'+ #' # Adding some values not considered in d_onco_rsp_label |
||
| 589 | +38 |
- #' @export+ #' |
||
| 590 | +39 |
- prop_diff_strat_nc <- function(rsp,+ #' d_onco_rsp_label( |
||
| 591 | +40 |
- grp,+ #' c("CR", "PR", "hello", "hi")
|
||
| 592 | +41 |
- strata,+ #' ) |
||
| 593 | +42 |
- weights_method = c("cmh", "wilson_h"),
+ #' |
||
| 594 | +43 |
- conf_level = 0.95,+ #' @export |
||
| 595 | +44 |
- correct = FALSE) {
+ d_onco_rsp_label <- function(x) {
|
||
| 596 | -4x | +45 | +2x |
- weights_method <- match.arg(weights_method)+ x <- as.character(x) |
| 597 | -4x | +46 | +2x |
- grp <- as_factor_keep_attributes(grp)+ desc <- c( |
| 598 | -4x | +47 | +2x |
- strata <- as_factor_keep_attributes(strata)+ CR = "Complete Response (CR)", |
| 599 | -4x | +48 | +2x |
- check_diff_prop_ci(+ PR = "Partial Response (PR)", |
| 600 | -4x | +49 | +2x |
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ MR = "Minimal/Minor Response (MR)", |
| 601 | -+ | |||
| 50 | +2x |
- )+ MRD = "Minimal Residual Disease (MRD)", |
||
| 602 | -4x | +51 | +2x |
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ SD = "Stable Disease (SD)", |
| 603 | -4x | +52 | +2x |
- checkmate::assert_flag(correct)+ PD = "Progressive Disease (PD)", |
| 604 | -4x | +53 | +2x |
- if (any(tapply(rsp, strata, length) < 5)) {
+ `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)", |
| 605 | -! | +|||
| 54 | +2x |
- warning("Less than 5 observations in some strata.")
+ NE = "Not Evaluable (NE)", |
||
| 606 | -+ | |||
| 55 | +2x |
- }+ `NE/Missing` = "Missing or unevaluable", |
||
| 607 | -+ | |||
| 56 | +2x |
-
+ Missing = "Missing", |
||
| 608 | -4x | +57 | +2x |
- rsp_by_grp <- split(rsp, f = grp)+ `NA` = "Not Applicable (NA)", |
| 609 | -4x | +58 | +2x |
- strata_by_grp <- split(strata, f = grp)+ ND = "Not Done (ND)" |
| 610 | +59 |
-
+ ) |
||
| 611 | +60 |
- # Finding the weights+ |
||
| 612 | -4x | +61 | +2x |
- weights <- if (identical(weights_method, "cmh")) {
+ values_label <- vapply( |
| 613 | -3x | +62 | +2x |
- prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights+ X = x, |
| 614 | -4x | +63 | +2x |
- } else if (identical(weights_method, "wilson_h")) {
+ FUN.VALUE = character(1), |
| 615 | -1x | -
- prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights- |
- ||
| 616 | -+ | 64 | +2x |
- }+ function(val) {
|
| 617 | -4x | +|||
| 65 | +! |
- weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0+ if (val %in% names(desc)) desc[val] else val |
||
| 618 | +66 |
-
+ } |
||
| 619 | +67 |
- # Calculating lower (`l`) and upper (`u`) confidence bounds per group.+ ) |
||
| 620 | -4x | +|||
| 68 | +
- strat_wilson_by_grp <- Map(+ |
|||
| 621 | -4x | +69 | +2x |
- prop_strat_wilson,+ return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc)))) |
| 622 | -4x | +|||
| 70 | +
- rsp = rsp_by_grp,+ } |
|||
| 623 | -4x | +|||
| 71 | +
- strata = strata_by_grp,+ |
|||
| 624 | -4x | +|||
| 72 | +
- weights = list(weights, weights),+ #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number |
|||
| 625 | -4x | +|||
| 73 | +
- conf_level = conf_level,+ #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()]. |
|||
| 626 | -4x | +|||
| 74 | +
- correct = correct+ #' |
|||
| 627 | +75 |
- )+ #' @return |
||
| 628 | +76 |
-
+ #' * `s_length_proportion()` returns statistics from [s_proportion()]. |
||
| 629 | -4x | +|||
| 77 | +
- ci_ref <- strat_wilson_by_grp[[1]]+ #' |
|||
| 630 | -4x | +|||
| 78 | +
- ci_trt <- strat_wilson_by_grp[[2]]+ #' @examples |
|||
| 631 | -4x | +|||
| 79 | +
- l_ref <- as.numeric(ci_ref$conf_int[1])+ #' s_length_proportion(rep("CR", 10), .N_col = 100)
|
|||
| 632 | -4x | +|||
| 80 | +
- u_ref <- as.numeric(ci_ref$conf_int[2])+ #' s_length_proportion(factor(character(0)), .N_col = 100) |
|||
| 633 | -4x | +|||
| 81 | +
- l_trt <- as.numeric(ci_trt$conf_int[1])+ #' |
|||
| 634 | -4x | +|||
| 82 | +
- u_trt <- as.numeric(ci_trt$conf_int[2])+ #' @export |
|||
| 635 | +83 |
-
+ s_length_proportion <- function(x, |
||
| 636 | +84 |
- # Estimating the diff and n_ref, n_trt (it allows different weights to be used)+ .N_col, # nolint |
||
| 637 | -4x | +|||
| 85 | +
- t_tbl <- table(+ ...) {
|
|||
| 638 | +86 | 4x |
- factor(rsp, levels = c("FALSE", "TRUE")),
+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
|
| 639 | -4x | +87 | +3x |
- grp,+ checkmate::assert_vector(x, min.len = 0, max.len = .N_col) |
| 640 | -4x | +88 | +2x |
- strata+ checkmate::assert_vector(unique(x), min.len = 0, max.len = 1) |
| 641 | +89 |
- )- |
- ||
| 642 | -4x | -
- n_ref <- colSums(t_tbl[1:2, 1, ])+ |
||
| 643 | -4x | +90 | +1x |
- n_trt <- colSums(t_tbl[1:2, 2, ])+ n_true <- length(x) |
| 644 | -4x | +91 | +1x |
- use_stratum <- (n_ref > 0) & (n_trt > 0)+ n_false <- .N_col - n_true |
| 645 | -4x | +92 | +1x |
- n_ref <- n_ref[use_stratum]+ x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false)) |
| 646 | -4x | +93 | +1x |
- n_trt <- n_trt[use_stratum]+ s_proportion(df = x_logical, ...) |
| 647 | -4x | +|||
| 94 | +
- p_ref <- t_tbl[2, 1, use_stratum] / n_ref+ } |
|||
| 648 | -4x | +|||
| 95 | +
- p_trt <- t_tbl[2, 2, use_stratum] / n_trt+ |
|||
| 649 | -4x | +|||
| 96 | +
- est1 <- sum(weights * p_ref)+ #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun` |
|||
| 650 | -4x | +|||
| 97 | +
- est2 <- sum(weights * p_trt)+ #' in `estimate_multinomial_response()`. |
|||
| 651 | -4x | +|||
| 98 | +
- diff_est <- est2 - est1+ #' |
|||
| 652 | +99 |
-
+ #' @return |
||
| 653 | -4x | +|||
| 100 | +
- lambda1 <- sum(weights^2 / n_ref)+ #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 654 | -4x | +|||
| 101 | +
- lambda2 <- sum(weights^2 / n_trt)+ #' |
|||
| 655 | -4x | +|||
| 102 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ #' @examples |
|||
| 656 | +103 |
-
+ #' a_length_proportion(rep("CR", 10), .N_col = 100)
|
||
| 657 | -4x | +|||
| 104 | +
- lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))+ #' a_length_proportion(factor(character(0)), .N_col = 100) |
|||
| 658 | -4x | +|||
| 105 | +
- upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ #' |
|||
| 659 | +106 |
-
+ #' @export |
||
| 660 | -4x | +|||
| 107 | +
- list(+ a_length_proportion <- make_afun( |
|||
| 661 | -4x | +|||
| 108 | +
- "diff" = diff_est,+ s_length_proportion, |
|||
| 662 | -4x | +|||
| 109 | +
- "diff_ci" = c("lower" = lower, "upper" = upper)
+ .formats = c( |
|||
| 663 | +110 |
- )+ n_prop = "xx (xx.x%)", |
||
| 664 | +111 |
- }+ prop_ci = "(xx.xx, xx.xx)" |
| 1 | +112 |
- #' Formatting functions+ ) |
||
| 2 | +113 |
- #'+ ) |
||
| 3 | +114 |
- #' See below for the list of formatting functions created in `tern` to work with `rtables`.+ |
||
| 4 | +115 |
- #'+ #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments |
||
| 5 | +116 |
- #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and |
||
| 6 | +117 |
- #' custom formats can be created via the [`formatters::sprintf_format()`] function.+ #' [rtables::summarize_row_groups()]. |
||
| 7 | +118 |
#' |
||
| 8 | +119 |
- #' @family formatting functions+ #' @return |
||
| 9 | +120 |
- #' @name formatting_functions+ #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions, |
||
| 10 | +121 |
- NULL+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 11 | +122 |
-
+ #' the statistics from `s_length_proportion()` to the table layout. |
||
| 12 | +123 |
- #' Format fraction and percentage+ #' |
||
| 13 | +124 |
- #'+ #' @examples |
||
| 14 | +125 |
- #' @description `r lifecycle::badge("stable")`
+ #' library(dplyr) |
||
| 15 | +126 |
#' |
||
| 16 | +127 |
- #' Formats a fraction together with ratio in percent.+ #' # Use of the layout creating function. |
||
| 17 | +128 |
- #'+ #' dta_test <- data.frame( |
||
| 18 | +129 |
- #' @param x (named `integer`)\cr vector with elements `num` and `denom`.+ #' USUBJID = paste0("S", 1:12),
|
||
| 19 | +130 |
- #' @param ... not used. Required for `rtables` interface.+ #' ARM = factor(rep(LETTERS[1:3], each = 4)), |
||
| 20 | +131 |
- #'+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0)) |
||
| 21 | +132 |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ #' ) %>% mutate( |
||
| 22 | +133 |
- #'+ #' AVALC = factor(AVAL, |
||
| 23 | +134 |
- #' @examples+ #' levels = c(0, 1), |
||
| 24 | +135 |
- #' format_fraction(x = c(num = 2L, denom = 3L))+ #' labels = c("Complete Response (CR)", "Partial Response (PR)")
|
||
| 25 | +136 |
- #' format_fraction(x = c(num = 0L, denom = 3L))+ #' ) |
||
| 26 | +137 |
- #'+ #' ) |
||
| 27 | +138 |
- #' @family formatting functions+ #' |
||
| 28 | +139 |
- #' @export+ #' lyt <- basic_table() %>% |
||
| 29 | +140 |
- format_fraction <- function(x, ...) {
- |
- ||
| 30 | -4x | -
- attr(x, "label") <- NULL+ #' split_cols_by("ARM") %>%
|
||
| 31 | +141 |
-
+ #' estimate_multinomial_response(var = "AVALC") |
||
| 32 | -4x | +|||
| 142 | +
- checkmate::assert_vector(x)+ #' |
|||
| 33 | -4x | +|||
| 143 | +
- checkmate::assert_count(x["num"])+ #' tbl <- build_table(lyt, dta_test) |
|||
| 34 | -2x | +|||
| 144 | +
- checkmate::assert_count(x["denom"])+ #' |
|||
| 35 | +145 |
-
+ #' tbl |
||
| 36 | -2x | +|||
| 146 | +
- result <- if (x["num"] == 0) {
+ #' |
|||
| 37 | -1x | +|||
| 147 | +
- paste0(x["num"], "/", x["denom"])+ #' @export |
|||
| 38 | +148 |
- } else {
+ #' @order 2 |
||
| 39 | -1x | +|||
| 149 | +
- paste0(+ estimate_multinomial_response <- function(lyt, |
|||
| 40 | -1x | +|||
| 150 | +
- x["num"], "/", x["denom"],+ var, |
|||
| 41 | -1x | +|||
| 151 | +
- " (", round(x["num"] / x["denom"] * 100, 1), "%)"
+ na_str = default_na_str(), |
|||
| 42 | +152 |
- )+ nested = TRUE, |
||
| 43 | -- |
- }- |
- ||
| 44 | -- | - - | -||
| 45 | -2x | -
- return(result)- |
- ||
| 46 | -- |
- }- |
- ||
| 47 | -- | - - | -||
| 48 | +153 |
- #' Format fraction and percentage with fixed single decimal place+ ..., |
||
| 49 | +154 |
- #'+ show_labels = "hidden", |
||
| 50 | +155 |
- #' @description `r lifecycle::badge("stable")`
+ table_names = var, |
||
| 51 | +156 |
- #'+ .stats = "prop_ci", |
||
| 52 | +157 |
- #' Formats a fraction together with ratio in percent with fixed single decimal place.+ .formats = NULL, |
||
| 53 | +158 |
- #' Includes trailing zero in case of whole number percentages to always keep one decimal place.+ .labels = NULL, |
||
| 54 | +159 |
- #'+ .indent_mods = NULL) {
|
||
| 55 | -+ | |||
| 160 | +1x |
- #' @inheritParams format_fraction+ extra_args <- list(...) |
||
| 56 | +161 |
- #'+ |
||
| 57 | -+ | |||
| 162 | +1x |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ afun <- make_afun( |
||
| 58 | -+ | |||
| 163 | +1x |
- #'+ a_length_proportion, |
||
| 59 | -+ | |||
| 164 | +1x |
- #' @examples+ .stats = .stats, |
||
| 60 | -+ | |||
| 165 | +1x |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L))+ .formats = .formats, |
||
| 61 | -+ | |||
| 166 | +1x |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L))+ .labels = .labels, |
||
| 62 | -+ | |||
| 167 | +1x |
- #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L))+ .indent_mods = .indent_mods |
||
| 63 | +168 |
- #'+ ) |
||
| 64 | -+ | |||
| 169 | +1x |
- #' @family formatting functions+ lyt <- split_rows_by(lyt, var = var) |
||
| 65 | -+ | |||
| 170 | +1x |
- #' @export+ lyt <- summarize_row_groups(lyt, na_str = na_str) |
||
| 66 | +171 |
- format_fraction_fixed_dp <- function(x, ...) {
+
|
||
| 67 | -3x | +172 | +1x |
- attr(x, "label") <- NULL+ analyze( |
| 68 | -3x | +173 | +1x |
- checkmate::assert_vector(x)+ lyt, |
| 69 | -3x | +174 | +1x |
- checkmate::assert_count(x["num"])+ vars = var, |
| 70 | -3x | -
- checkmate::assert_count(x["denom"])- |
- ||
| 71 | -+ | 175 | +1x |
-
+ afun = afun, |
| 72 | -3x | +176 | +1x |
- result <- if (x["num"] == 0) {
+ show_labels = show_labels, |
| 73 | +177 | 1x |
- paste0(x["num"], "/", x["denom"])- |
- |
| 74 | -- |
- } else {
+ table_names = table_names, |
||
| 75 | -2x | +178 | +1x |
- paste0(+ na_str = na_str, |
| 76 | -2x | +179 | +1x |
- x["num"], "/", x["denom"],+ nested = nested, |
| 77 | -2x | -
- " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
- |
- ||
| 78 | -+ | 180 | +1x |
- )+ extra_args = extra_args |
| 79 | +181 |
- }- |
- ||
| 80 | -3x | -
- return(result)+ ) |
||
| 81 | +182 |
} |
| 82 | -- | - - | -||
| 83 | +1 |
- #' Format count and fraction+ #' Helper functions for tabulating biomarker effects on binary response by subgroup |
||
| 84 | +2 |
#' |
||
| 85 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 86 | +4 |
#' |
||
| 87 | +5 |
- #' Formats a count together with fraction with special consideration when count is `0`.+ #' Helper functions which are documented here separately to not confuse the user |
||
| 88 | +6 |
- #'+ #' when reading about the user-facing functions. |
||
| 89 | +7 |
- #' @param x (`numeric(2)`)\cr vector of length 2 with count and fraction, respectively.+ #' |
||
| 90 | +8 |
- #' @param ... not used. Required for `rtables` interface.+ #' @inheritParams response_biomarkers_subgroups |
||
| 91 | +9 |
- #'+ #' @inheritParams extract_rsp_biomarkers |
||
| 92 | +10 |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ #' @inheritParams argument_convention |
||
| 93 | +11 |
#' |
||
| 94 | +12 |
#' @examples |
||
| 95 | +13 |
- #' format_count_fraction(x = c(2, 0.6667))+ #' library(dplyr) |
||
| 96 | +14 |
- #' format_count_fraction(x = c(0, 0))+ #' library(forcats) |
||
| 97 | +15 |
#' |
||
| 98 | +16 |
- #' @family formatting functions+ #' adrs <- tern_ex_adrs |
||
| 99 | +17 |
- #' @export+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 100 | +18 |
- format_count_fraction <- function(x, ...) {
- |
- ||
| 101 | -3x | -
- attr(x, "label") <- NULL+ #' |
||
| 102 | +19 | - - | -||
| 103 | -3x | -
- if (any(is.na(x))) {
- |
- ||
| 104 | -1x | -
- return("NA")
+ #' adrs_f <- adrs %>% |
||
| 105 | +20 |
- }+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 106 | +21 | - - | -||
| 107 | -2x | -
- checkmate::assert_vector(x)- |
- ||
| 108 | -2x | -
- checkmate::assert_integerish(x[1])- |
- ||
| 109 | -2x | -
- assert_proportion_value(x[2], include_boundaries = TRUE)+ #' mutate(rsp = AVALC == "CR") |
||
| 110 | +22 | - - | -||
| 111 | -2x | -
- result <- if (x[1] == 0) {
- |
- ||
| 112 | -1x | -
- "0"+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 113 | +23 |
- } else {
+ #' |
||
| 114 | -1x | +|||
| 24 | +
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ #' @name h_response_biomarkers_subgroups |
|||
| 115 | +25 |
- }+ NULL |
||
| 116 | +26 | |||
| 117 | -2x | -
- return(result)- |
- ||
| 118 | +27 |
- }+ #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list |
||
| 119 | +28 |
-
+ #' to the "logistic regression" variable list. The reason is that currently there is an |
||
| 120 | +29 |
- #' Format count and percentage with fixed single decimal place+ #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`. |
||
| 121 | +30 |
#' |
||
| 122 | +31 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
||
| 123 | +32 |
#' |
||
| 124 | +33 |
- #' Formats a count together with fraction with special consideration when count is `0`.+ #' @return |
||
| 125 | +34 |
- #'+ #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`. |
||
| 126 | +35 |
- #' @inheritParams format_count_fraction+ #' |
||
| 127 | +36 |
- #'+ #' @examples |
||
| 128 | +37 |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ #' # This is how the variable list is converted internally. |
||
| 129 | +38 |
- #'+ #' h_rsp_to_logistic_variables( |
||
| 130 | +39 |
- #' @examples+ #' variables = list( |
||
| 131 | +40 |
- #' format_count_fraction_fixed_dp(x = c(2, 0.6667))+ #' rsp = "RSP", |
||
| 132 | +41 |
- #' format_count_fraction_fixed_dp(x = c(2, 0.5))+ #' covariates = c("A", "B"),
|
||
| 133 | +42 |
- #' format_count_fraction_fixed_dp(x = c(0, 0))+ #' strata = "D" |
||
| 134 | +43 |
- #'+ #' ), |
||
| 135 | +44 |
- #' @family formatting functions+ #' biomarker = "AGE" |
||
| 136 | +45 |
- #' @export+ #' ) |
||
| 137 | +46 |
- format_count_fraction_fixed_dp <- function(x, ...) {
+ #' |
||
| 138 | -1396x | +|||
| 47 | +
- attr(x, "label") <- NULL+ #' @export |
|||
| 139 | +48 |
-
+ h_rsp_to_logistic_variables <- function(variables, biomarker) {
|
||
| 140 | -1396x | +49 | +49x |
- if (any(is.na(x))) {
+ if ("strat" %in% names(variables)) {
|
| 141 | +50 | ! |
- return("NA")
+ warning( |
|
| 142 | -+ | |||
| 51 | +! |
- }+ "Warning: the `strat` element name of the `variables` list argument to `h_rsp_to_logistic_variables() ", |
||
| 143 | -+ | |||
| 52 | +! |
-
+ "was deprecated in tern 0.9.4.\n ", |
||
| 144 | -1396x | +|||
| 53 | +! |
- checkmate::assert_vector(x)+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 145 | -1396x | +|||
| 54 | +
- checkmate::assert_integerish(x[1])+ ) |
|||
| 146 | -1396x | +|||
| 55 | +! |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ variables[["strata"]] <- variables[["strat"]] |
||
| 147 | +56 |
-
+ } |
||
| 148 | -1396x | +57 | +49x |
- result <- if (x[1] == 0) {
+ checkmate::assert_list(variables) |
| 149 | -192x | +58 | +49x |
- "0"+ checkmate::assert_string(variables$rsp) |
| 150 | -1396x | +59 | +49x |
- } else if (.is_equal_float(x[2], 1)) {
+ checkmate::assert_string(biomarker) |
| 151 | -549x | +60 | +49x |
- sprintf("%d (100%%)", x[1])
+ list( |
| 152 | -+ | |||
| 61 | +49x |
- } else {
+ response = variables$rsp, |
||
| 153 | -655x | +62 | +49x |
- sprintf("%d (%.1f%%)", x[1], x[2] * 100)
+ arm = biomarker, |
| 154 | -+ | |||
| 63 | +49x |
- }+ covariates = variables$covariates, |
||
| 155 | -+ | |||
| 64 | +49x |
-
+ strata = variables$strata |
||
| 156 | -1396x | +|||
| 65 | +
- return(result)+ ) |
|||
| 157 | +66 |
} |
||
| 158 | +67 | |||
| 159 | +68 |
- #' Format count and fraction with special case for count < 10+ #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and |
||
| 160 | +69 |
- #'+ #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple |
||
| 161 | +70 |
- #' @description `r lifecycle::badge("stable")`
+ #' biomarkers in a given single data set. |
||
| 162 | +71 |
- #'+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
||
| 163 | +72 |
- #' Formats a count together with fraction with special consideration when count is less than 10.+ #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates` |
||
| 164 | +73 |
- #'+ #' and `strata`. |
||
| 165 | +74 |
- #' @inheritParams format_count_fraction+ #' |
||
| 166 | +75 |
- #'+ #' @return |
||
| 167 | +76 |
- #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed.+ #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
||
| 168 | +77 |
#' |
||
| 169 | +78 |
#' @examples |
||
| 170 | +79 |
- #' format_count_fraction_lt10(x = c(275, 0.9673))+ #' # For a single population, estimate separately the effects |
||
| 171 | +80 |
- #' format_count_fraction_lt10(x = c(2, 0.6667))+ #' # of two biomarkers. |
||
| 172 | +81 |
- #' format_count_fraction_lt10(x = c(9, 1))+ #' df <- h_logistic_mult_cont_df( |
||
| 173 | +82 |
- #'+ #' variables = list( |
||
| 174 | +83 |
- #' @family formatting functions+ #' rsp = "rsp", |
||
| 175 | +84 |
- #' @export+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 176 | +85 |
- format_count_fraction_lt10 <- function(x, ...) {
- |
- ||
| 177 | -7x | -
- attr(x, "label") <- NULL+ #' covariates = "SEX" |
||
| 178 | +86 | - - | -||
| 179 | -7x | -
- if (any(is.na(x))) {
- |
- ||
| 180 | -1x | -
- return("NA")
+ #' ), |
||
| 181 | +87 |
- }+ #' data = adrs_f |
||
| 182 | +88 | - - | -||
| 183 | -6x | -
- checkmate::assert_vector(x)- |
- ||
| 184 | -6x | -
- checkmate::assert_integerish(x[1])- |
- ||
| 185 | -6x | -
- assert_proportion_value(x[2], include_boundaries = TRUE)+ #' ) |
||
| 186 | +89 | - - | -||
| 187 | -6x | -
- result <- if (x[1] < 10) {
- |
- ||
| 188 | -3x | -
- paste0(x[1])+ #' df |
||
| 189 | +90 |
- } else {
- |
- ||
| 190 | -3x | -
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ #' |
||
| 191 | +91 |
- }+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
||
| 192 | +92 | - - | -||
| 193 | -6x | -
- return(result)+ #' h_coxreg_mult_cont_df( |
||
| 194 | +93 |
- }+ #' variables = list( |
||
| 195 | +94 |
-
+ #' rsp = "rsp", |
||
| 196 | +95 |
- #' Format XX as a formatting function+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 197 | +96 |
- #'+ #' covariates = "SEX", |
||
| 198 | +97 |
- #' Translate a string where x and dots are interpreted as number place+ #' strata = "STRATA1" |
||
| 199 | +98 |
- #' holders, and others as formatting elements.+ #' ), |
||
| 200 | +99 |
- #'+ #' data = adrs_f[NULL, ] |
||
| 201 | +100 |
- #' @param str (`string`)\cr template.+ #' ) |
||
| 202 | +101 |
#' |
||
| 203 | -- |
- #' @return An `rtables` formatting function.- |
- ||
| 204 | +102 |
- #'+ #' @export |
||
| 205 | +103 |
- #' @examples+ h_logistic_mult_cont_df <- function(variables, |
||
| 206 | +104 |
- #' test <- list(c(1.658, 0.5761), c(1e1, 785.6))+ data, |
||
| 207 | +105 |
- #'+ control = control_logistic()) {
|
||
| 208 | -+ | |||
| 106 | +28x |
- #' z <- format_xx("xx (xx.x)")
+ if ("strat" %in% names(variables)) {
|
||
| 209 | -+ | |||
| 107 | +! |
- #' sapply(test, z)+ warning( |
||
| 210 | -+ | |||
| 108 | +! |
- #'+ "Warning: the `strat` element name of the `variables` list argument to `h_logistic_mult_cont_df() ", |
||
| 211 | -+ | |||
| 109 | +! |
- #' z <- format_xx("xx.x - xx.x")
+ "was deprecated in tern 0.9.4.\n ", |
||
| 212 | -+ | |||
| 110 | +! |
- #' sapply(test, z)+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 213 | +111 |
- #'+ ) |
||
| 214 | -+ | |||
| 112 | +! |
- #' z <- format_xx("xx.x, incl. xx.x% NE")
+ variables[["strata"]] <- variables[["strat"]] |
||
| 215 | +113 |
- #' sapply(test, z)+ } |
||
| 216 | -+ | |||
| 114 | +28x |
- #'+ assert_df_with_variables(data, variables) |
||
| 217 | +115 |
- #' @family formatting functions+ |
||
| 218 | -+ | |||
| 116 | +28x |
- #' @export+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
||
| 219 | -+ | |||
| 117 | +28x |
- format_xx <- function(str) {
+ checkmate::assert_list(control, names = "named") |
||
| 220 | +118 |
- # Find position in the string.+ |
||
| 221 | -1x | +119 | +28x |
- positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE)+ conf_level <- control[["conf_level"]] |
| 222 | -1x | +120 | +28x |
- x_positions <- regmatches(x = str, m = positions)[[1]]+ pval_label <- "p-value (Wald)" |
| 223 | +121 | |||
| 224 | +122 |
- # Roundings depends on the number of x behind [.].+ # If there is any data, run model, otherwise return empty results. |
||
| 225 | -1x | +123 | +28x |
- roundings <- lapply(+ if (nrow(data) > 0) {
|
| 226 | -1x | +124 | +27x |
- X = x_positions,+ bm_cols <- match(variables$biomarkers, names(data)) |
| 227 | -1x | +125 | +27x |
- function(x) {
+ l_result <- lapply(variables$biomarkers, function(bm) {
|
| 228 | -2x | +126 | +48x |
- y <- strsplit(split = "\\.", x = x)[[1]]+ model_fit <- fit_logistic( |
| 229 | -2x | +127 | +48x |
- rounding <- function(x) {
+ variables = h_rsp_to_logistic_variables(variables, bm), |
| 230 | -4x | -
- round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0))- |
- ||
| 231 | -+ | 128 | +48x |
- }+ data = data, |
| 232 | -2x | -
- return(rounding)- |
- ||
| 233 | -- |
- }- |
- ||
| 234 | -+ | 129 | +48x |
- )+ response_definition = control$response_definition |
| 235 | +130 |
-
+ ) |
||
| 236 | -1x | +131 | +48x |
- rtable_format <- function(x, output) {
+ result <- h_logistic_simple_terms( |
| 237 | -2x | +132 | +48x |
- values <- Map(y = x, fun = roundings, function(y, fun) fun(y))+ x = bm, |
| 238 | -2x | +133 | +48x |
- regmatches(x = str, m = positions)[[1]] <- values+ fit_glm = model_fit, |
| 239 | -2x | +134 | +48x |
- return(str)+ conf_level = control$conf_level |
| 240 | +135 |
- }+ ) |
||
| 241 | -+ | |||
| 136 | +48x |
-
+ resp_vector <- if (inherits(model_fit, "glm")) {
|
||
| 242 | -1x | +137 | +38x |
- return(rtable_format)+ model_fit$model[[variables$rsp]] |
| 243 | +138 |
- }+ } else {
|
||
| 244 | -+ | |||
| 139 | +10x |
-
+ as.logical(as.matrix(model_fit$y)[, "status"]) |
||
| 245 | +140 |
- #' Format numeric values by significant figures+ } |
||
| 246 | -+ | |||
| 141 | +48x |
- #'+ data.frame( |
||
| 247 | +142 |
- #' Format numeric values to print with a specified number of significant figures.+ # Dummy column needed downstream to create a nested header. |
||
| 248 | -+ | |||
| 143 | +48x |
- #'+ biomarker = bm, |
||
| 249 | -+ | |||
| 144 | +48x |
- #' @param sigfig (`integer(1)`)\cr number of significant figures to display.+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE), |
||
| 250 | -+ | |||
| 145 | +48x |
- #' @param format (`string`)\cr the format label (string) to apply when printing the value. Decimal+ n_tot = length(resp_vector), |
||
| 251 | -+ | |||
| 146 | +48x |
- #' places in string are ignored in favor of formatting by significant figures. Formats options are:+ n_rsp = sum(resp_vector), |
||
| 252 | -+ | |||
| 147 | +48x |
- #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`.+ prop = mean(resp_vector), |
||
| 253 | -+ | |||
| 148 | +48x |
- #' @param num_fmt (`string`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for+ or = as.numeric(result[1L, "odds_ratio"]), |
||
| 254 | -+ | |||
| 149 | +48x |
- #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`)+ lcl = as.numeric(result[1L, "lcl"]), |
||
| 255 | -+ | |||
| 150 | +48x |
- #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the+ ucl = as.numeric(result[1L, "ucl"]), |
||
| 256 | -+ | |||
| 151 | +48x |
- #' [formatC()] `format` argument for more options.+ conf_level = conf_level, |
||
| 257 | -+ | |||
| 152 | +48x |
- #'+ pval = as.numeric(result[1L, "pvalue"]), |
||
| 258 | -+ | |||
| 153 | +48x |
- #' @return An `rtables` formatting function.+ pval_label = pval_label, |
||
| 259 | -+ | |||
| 154 | +48x |
- #'+ stringsAsFactors = FALSE |
||
| 260 | +155 |
- #' @examples+ ) |
||
| 261 | +156 |
- #' fmt_3sf <- format_sigfig(3)+ }) |
||
| 262 | -+ | |||
| 157 | +27x |
- #' fmt_3sf(1.658)+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 263 | +158 |
- #' fmt_3sf(1e1)+ } else {
|
||
| 264 | -+ | |||
| 159 | +1x |
- #'+ data.frame( |
||
| 265 | -+ | |||
| 160 | +1x |
- #' fmt_5sf <- format_sigfig(5)+ biomarker = variables$biomarkers, |
||
| 266 | -+ | |||
| 161 | +1x |
- #' fmt_5sf(0.57)+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE), |
||
| 267 | -+ | |||
| 162 | +1x |
- #' fmt_5sf(0.000025645)+ n_tot = 0L, |
||
| 268 | -+ | |||
| 163 | +1x |
- #'+ n_rsp = 0L, |
||
| 269 | -+ | |||
| 164 | +1x |
- #' @family formatting functions+ prop = NA, |
||
| 270 | -+ | |||
| 165 | +1x |
- #' @export+ or = NA, |
||
| 271 | -+ | |||
| 166 | +1x |
- format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
+ lcl = NA, |
||
| 272 | -3x | +167 | +1x |
- checkmate::assert_integerish(sigfig)+ ucl = NA, |
| 273 | -3x | +168 | +1x |
- format <- gsub("xx\\.|xx\\.x+", "xx", format)
+ conf_level = conf_level, |
| 274 | -3x | +169 | +1x |
- checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
+ pval = NA, |
| 275 | -3x | +170 | +1x |
- function(x, ...) {
+ pval_label = pval_label, |
| 276 | -! | +|||
| 171 | +1x |
- if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
+ row.names = seq_along(variables$biomarkers), |
||
| 277 | -12x | +172 | +1x |
- num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#")+ stringsAsFactors = FALSE |
| 278 | -12x | +|||
| 173 | +
- num <- gsub("\\.$", "", num) # remove trailing "."
+ ) |
|||
| 279 | +174 | ++ |
+ }+ |
+ |
| 175 | ++ |
+ }+ |
+ ||
| 176 | ||||
| 280 | -12x | +|||
| 177 | +
- format_value(num, format)+ #' @describeIn h_response_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing |
|||
| 281 | +178 |
- }+ #' the results for a single biomarker. |
||
| 282 | +179 |
- }+ #' |
||
| 283 | +180 |
-
+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 284 | +181 |
- #' Format fraction with lower threshold+ #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are |
||
| 285 | +182 |
- #'+ #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()], |
||
| 286 | +183 |
- #' @description `r lifecycle::badge("stable")`
+ #' see the example). |
||
| 287 | +184 |
#' |
||
| 288 | +185 |
- #' Formats a fraction when the second element of the input `x` is the fraction. It applies+ #' @return |
||
| 289 | +186 |
- #' a lower threshold, below which it is just stated that the fraction is smaller than that.+ #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
||
| 290 | +187 |
#' |
||
| 291 | +188 |
- #' @param threshold (`proportion`)\cr lower threshold.+ #' @examples |
||
| 292 | +189 |
- #'+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
||
| 293 | +190 |
- #' @return An `rtables` formatting function that takes numeric input `x` where the second+ #' df1 <- df[1, ] |
||
| 294 | +191 |
- #' element is the fraction that is formatted. If the fraction is above or equal to the threshold,+ #' df1$subgroup <- "All patients" |
||
| 295 | +192 |
- #' then it is displayed in percentage. If it is positive but below the threshold, it returns,+ #' df1$row_type <- "content" |
||
| 296 | +193 |
- #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned.+ #' df1$var <- "ALL" |
||
| 297 | +194 |
- #'+ #' df1$var_label <- "All patients" |
||
| 298 | +195 |
- #' @examples+ #' |
||
| 299 | +196 |
- #' format_fun <- format_fraction_threshold(0.05)+ #' h_tab_rsp_one_biomarker( |
||
| 300 | +197 |
- #' format_fun(x = c(20, 0.1))+ #' df1, |
||
| 301 | +198 |
- #' format_fun(x = c(2, 0.01))+ #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
|
||
| 302 | +199 |
- #' format_fun(x = c(0, 0))+ #' ) |
||
| 303 | +200 |
#' |
||
| 304 | +201 |
- #' @family formatting functions+ #' @export |
||
| 305 | +202 |
- #' @export+ h_tab_rsp_one_biomarker <- function(df, |
||
| 306 | +203 |
- format_fraction_threshold <- function(threshold) {
+ vars, |
||
| 307 | -1x | +|||
| 204 | +
- assert_proportion_value(threshold)+ na_str = default_na_str(),+ |
+ |||
| 205 | ++ |
+ .indent_mods = 0L) {
|
||
| 308 | -1x | +206 | +8x |
- string_below_threshold <- paste0("<", round(threshold * 100))
+ afuns <- a_response_subgroups(na_str = na_str)[vars] |
| 309 | -1x | +207 | +8x |
- function(x, ...) {
+ colvars <- d_rsp_subgroups_colvars( |
| 310 | -3x | +208 | +8x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ vars, |
| 311 | -3x | +209 | +8x |
- ifelse(+ conf_level = df$conf_level[1], |
| 312 | -3x | +210 | +8x |
- x[2] > 0.01,+ method = df$pval_label[1]+ |
+
| 211 | ++ |
+ ) |
||
| 313 | -3x | +212 | +8x |
- round(x[2] * 100),+ h_tab_one_biomarker( |
| 314 | -3x | +213 | +8x |
- ifelse(+ df = df, |
| 315 | -3x | +214 | +8x |
- x[2] == 0,+ afuns = afuns, |
| 316 | -3x | +215 | +8x |
- "0",+ colvars = colvars, |
| 317 | -3x | +216 | +8x |
- string_below_threshold+ na_str = na_str, |
| 318 | -+ | |||
| 217 | +8x |
- )+ .indent_mods = .indent_mods |
||
| 319 | +218 |
- )+ ) |
||
| 320 | +219 |
- }+ } |
| 321 | +1 |
- }+ # Utility functions to cooperate with {rtables} package
|
||
| 322 | +2 | |||
| 323 | +3 |
- #' Format extreme values+ #' Convert table into matrix of strings |
||
| 324 | +4 |
#' |
||
| 325 | +5 |
#' @description `r lifecycle::badge("stable")`
|
||
| 326 | +6 |
#' |
||
| 327 | +7 |
- #' `rtables` formatting functions that handle extreme values.+ #' Helper function to use mostly within tests. `with_spaces`parameter allows |
||
| 328 | +8 |
- #'+ #' to test not only for content but also indentation and table structure. |
||
| 329 | +9 |
- #' @param digits (`integer(1)`)\cr number of decimal places to display.+ #' `print_txt_to_copy` instead facilitate the testing development by returning a well |
||
| 330 | +10 |
- #'+ #' formatted text that needs only to be copied and pasted in the expected output. |
||
| 331 | +11 |
- #' @details For each input, apply a format to the specified number of `digits`. If the value is+ #' |
||
| 332 | +12 |
- #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is+ #' @inheritParams formatters::toString |
||
| 333 | +13 |
- #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2.+ #' @param x (`VTableTree`)\cr `rtables` table object. |
||
| 334 | +14 |
- #' If it is zero, then returns "0.00".+ #' @param with_spaces (`flag`)\cr whether the tested table should keep the indentation and other relevant spaces. |
||
| 335 | +15 |
- #'+ #' @param print_txt_to_copy (`flag`)\cr utility to have a way to copy the input table directly |
||
| 336 | +16 |
- #' @family formatting functions+ #' into the expected variable instead of copying it too manually. |
||
| 337 | +17 |
- #' @name extreme_format+ #' |
||
| 338 | +18 |
- NULL+ #' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the |
||
| 339 | +19 |
-
+ #' table will be printed to console, ready to be copied as a expected value. |
||
| 340 | +20 |
- #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings+ #' |
||
| 341 | +21 |
- #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`.+ #' @examples |
||
| 342 | +22 |
- #'+ #' tbl <- basic_table() %>% |
||
| 343 | +23 |
- #' @return+ #' split_rows_by("SEX") %>%
|
||
| 344 | +24 |
- #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds,+ #' split_cols_by("ARM") %>%
|
||
| 345 | +25 |
- #' and `format_string`, with thresholds formatted as strings.+ #' analyze("AGE") %>%
|
||
| 346 | +26 |
- #'+ #' build_table(tern_ex_adsl) |
||
| 347 | +27 |
- #' @examples+ #' |
||
| 348 | +28 |
- #' h_get_format_threshold(2L)+ #' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2)) |
||
| 349 | +29 |
#' |
||
| 350 | +30 |
#' @export |
||
| 351 | +31 |
- h_get_format_threshold <- function(digits = 2L) {
- |
- ||
| 352 | -2113x | -
- checkmate::assert_integerish(digits)+ to_string_matrix <- function(x, widths = NULL, max_width = NULL, |
||
| 353 | +32 |
-
+ hsep = formatters::default_hsep(), |
||
| 354 | -2113x | +|||
| 33 | +
- low_threshold <- 1 / (10 ^ digits) # styler: off+ with_spaces = TRUE, print_txt_to_copy = FALSE) {
|
|||
| 355 | -2113x | -
- high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off- |
- ||
| 356 | -+ | 34 | +11x |
-
+ checkmate::assert_flag(with_spaces) |
| 357 | -2113x | +35 | +11x |
- string_below_threshold <- paste0("<", low_threshold)
+ checkmate::assert_flag(print_txt_to_copy) |
| 358 | -2113x | +36 | +11x |
- string_above_threshold <- paste0(">", high_threshold)
+ checkmate::assert_int(max_width, null.ok = TRUE) |
| 359 | +37 | |||
| 360 | -2113x | -
- list(- |
- ||
| 361 | -2113x | +38 | +11x |
- "threshold" = c(low = low_threshold, high = high_threshold),+ if (inherits(x, "MatrixPrintForm")) {
|
| 362 | -2113x | +|||
| 39 | +! |
- "format_string" = c(low = string_below_threshold, high = string_above_threshold)+ tx <- x |
||
| 363 | +40 |
- )+ } else {
|
||
| 364 | -+ | |||
| 41 | +11x |
- }+ tx <- matrix_form(x, TRUE) |
||
| 365 | +42 |
-
+ } |
||
| 366 | +43 |
- #' @describeIn extreme_format Internal helper function to apply a threshold format to a value.+ |
||
| 367 | -+ | |||
| 44 | +11x |
- #' Creates a formatted string to be used in Formatting Functions.+ tf_wrap <- FALSE |
||
| 368 | -+ | |||
| 45 | +11x |
- #'+ if (!is.null(max_width)) {
|
||
| 369 | -+ | |||
| 46 | +! |
- #' @param x (`numeric(1)`)\cr value to format.+ tf_wrap <- TRUE |
||
| 370 | +47 |
- #'+ } |
||
| 371 | +48 |
- #' @return+ |
||
| 372 | +49 |
- #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation+ # Producing the matrix to test |
||
| 373 | -+ | |||
| 50 | +11x |
- #' of the given value to the digit threshold, as a formatted string.+ if (with_spaces) {
|
||
| 374 | -+ | |||
| 51 | +2x |
- #'+ out <- strsplit(toString(tx, widths = widths, tf_wrap = tf_wrap, max_width = max_width, hsep = hsep), "\n")[[1]] |
||
| 375 | +52 |
- #' @examples+ } else {
|
||
| 376 | -+ | |||
| 53 | +9x |
- #' h_format_threshold(0.001)+ out <- tx$strings |
||
| 377 | +54 |
- #' h_format_threshold(1000)+ } |
||
| 378 | +55 |
- #'+ |
||
| 379 | +56 |
- #' @export+ # Printing to console formatted output that needs to be copied in "expected" |
||
| 380 | -+ | |||
| 57 | +11x |
- h_format_threshold <- function(x, digits = 2L) {
+ if (print_txt_to_copy) {
|
||
| 381 | -2115x | +58 | +2x |
- if (is.na(x)) {
+ out_tmp <- out |
| 382 | -4x | +59 | +2x |
- return(x)+ if (!with_spaces) {
|
| 383 | -+ | |||
| 60 | +1x |
- }+ out_tmp <- apply(out, 1, paste0, collapse = '", "') |
||
| 384 | +61 |
-
+ } |
||
| 385 | -2111x | +62 | +2x |
- checkmate::assert_numeric(x, lower = 0)+ cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
|
| 386 | +63 | - - | -||
| 387 | -2111x | -
- l_fmt <- h_get_format_threshold(digits)+ } |
||
| 388 | +64 | |||
| 389 | -2111x | -
- result <- if (x < l_fmt$threshold["low"] && 0 < x) {
- |
- ||
| 390 | -44x | -
- l_fmt$format_string["low"]- |
- ||
| 391 | -2111x | -
- } else if (x > l_fmt$threshold["high"]) {
- |
- ||
| 392 | -99x | -
- l_fmt$format_string["high"]- |
- ||
| 393 | +65 |
- } else {
+ # Return values |
||
| 394 | -1968x | +66 | +11x |
- sprintf(fmt = paste0("%.", digits, "f"), x)
+ return(out) |
| 395 | +67 |
- }+ } |
||
| 396 | +68 | |||
| 397 | -2111x | -
- unname(result)- |
- ||
| 398 | +69 |
- }+ #' Blank for missing input |
||
| 399 | +70 |
-
+ #' |
||
| 400 | +71 |
- #' Format a single extreme value+ #' Helper function to use in tabulating model results. |
||
| 401 | +72 |
#' |
||
| 402 | +73 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param x (`vector`)\cr input for a cell. |
||
| 403 | +74 |
#' |
||
| 404 | +75 |
- #' Create a formatting function for a single extreme value.+ #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise |
||
| 405 | +76 |
- #'+ #' the unlisted version of `x`. |
||
| 406 | +77 |
- #' @inheritParams extreme_format+ #' |
||
| 407 | +78 |
- #'+ #' @keywords internal |
||
| 408 | +79 |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value.+ unlist_and_blank_na <- function(x) {
|
||
| 409 | -+ | |||
| 80 | +267x |
- #'+ unl <- unlist(x) |
||
| 410 | -+ | |||
| 81 | +267x |
- #' @examples+ if (all(is.na(unl))) {
|
||
| 411 | -+ | |||
| 82 | +161x |
- #' format_fun <- format_extreme_values(2L)+ character() |
||
| 412 | +83 |
- #' format_fun(x = 0.127)+ } else {
|
||
| 413 | -+ | |||
| 84 | +106x |
- #' format_fun(x = Inf)+ unl |
||
| 414 | +85 |
- #' format_fun(x = 0)+ } |
||
| 415 | +86 |
- #' format_fun(x = 0.009)+ } |
||
| 416 | +87 |
- #'+ |
||
| 417 | +88 |
- #' @family formatting functions+ #' Constructor for content functions given a data frame with flag input |
||
| 418 | +89 |
- #' @export+ #' |
||
| 419 | +90 |
- format_extreme_values <- function(digits = 2L) {
+ #' This can be useful for tabulating model results. |
||
| 420 | -63x | +|||
| 91 | +
- function(x, ...) {
+ #' |
|||
| 421 | -657x | +|||
| 92 | +
- checkmate::assert_scalar(x, na.ok = TRUE)+ #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the |
|||
| 422 | +93 |
-
+ #' content function. |
||
| 423 | -657x | +|||
| 94 | +
- h_format_threshold(x = x, digits = digits)+ #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned. |
|||
| 424 | +95 |
- }+ #' @param format (`string`)\cr `rtables` format to use. |
||
| 425 | +96 |
- }+ #' |
||
| 426 | +97 |
-
+ #' @return A content function which gives `df$analysis_var` at the row identified by |
||
| 427 | +98 |
- #' Format extreme values part of a confidence interval+ #' `.df_row$flag` in the given format. |
||
| 428 | +99 |
#' |
||
| 429 | +100 |
- #' @description `r lifecycle::badge("stable")`
+ #' @keywords internal |
||
| 430 | +101 |
- #'+ cfun_by_flag <- function(analysis_var, |
||
| 431 | +102 |
- #' Formatting Function for extreme values part of a confidence interval. Values+ flag_var, |
||
| 432 | +103 |
- #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2.+ format = "xx", |
||
| 433 | +104 |
- #'+ .indent_mods = NULL) {
|
||
| 434 | -+ | |||
| 105 | +61x |
- #' @inheritParams extreme_format+ checkmate::assert_string(analysis_var) |
||
| 435 | -+ | |||
| 106 | +61x |
- #'+ checkmate::assert_string(flag_var) |
||
| 436 | -+ | |||
| 107 | +61x |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme+ function(df, labelstr) {
|
||
| 437 | -+ | |||
| 108 | +265x |
- #' values confidence interval.+ row_index <- which(df[[flag_var]]) |
||
| 438 | -+ | |||
| 109 | +265x |
- #'+ x <- unlist_and_blank_na(df[[analysis_var]][row_index]) |
||
| 439 | -+ | |||
| 110 | +265x |
- #' @examples+ formatters::with_label( |
||
| 440 | -+ | |||
| 111 | +265x |
- #' format_fun <- format_extreme_values_ci(2L)+ rcell(x, format = format, indent_mod = .indent_mods), |
||
| 441 | -+ | |||
| 112 | +265x |
- #' format_fun(x = c(0.127, Inf))+ labelstr |
||
| 442 | +113 |
- #' format_fun(x = c(0, 0.009))+ ) |
||
| 443 | +114 |
- #'+ } |
||
| 444 | +115 |
- #' @family formatting functions+ } |
||
| 445 | +116 |
- #' @export+ |
||
| 446 | +117 |
- format_extreme_values_ci <- function(digits = 2L) {
- |
- ||
| 447 | -71x | -
- function(x, ...) {
- |
- ||
| 448 | -726x | -
- checkmate::assert_vector(x, len = 2)- |
- ||
| 449 | -726x | -
- l_result <- h_format_threshold(x = x[1], digits = digits)- |
- ||
| 450 | -726x | -
- h_result <- h_format_threshold(x = x[2], digits = digits)+ #' Content row function to add row total to labels |
||
| 451 | +118 |
-
+ #' |
||
| 452 | -726x | +|||
| 119 | +
- paste0("(", l_result, ", ", h_result, ")")
+ #' This takes the label of the latest row split level and adds the row total from `df` in parentheses. |
|||
| 453 | +120 |
- }+ #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than |
||
| 454 | +121 |
- }+ #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`. |
||
| 455 | +122 |
-
+ #' |
||
| 456 | +123 |
- #' Format automatically using data significant digits+ #' @inheritParams argument_convention |
||
| 457 | +124 |
#' |
||
| 458 | +125 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
||
| 459 | +126 |
#' |
||
| 460 | +127 |
- #' Formatting function for the majority of default methods used in [analyze_vars()].+ #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because |
||
| 461 | +128 |
- #' For non-derived values, the significant digits of data is used (e.g. range), while derived+ #' the former is already split by columns and will refer to the first column of the data only. |
||
| 462 | +129 |
- #' values have one more digits (measure of location and dispersion like mean, standard deviation).+ #' |
||
| 463 | +130 |
- #' This function can be called internally with "auto" like, for example,+ #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from |
||
| 464 | +131 |
- #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
+ #' `alt_counts_df` instead of `df`. |
||
| 465 | +132 |
#' |
||
| 466 | +133 |
- #' @param dt_var (`numeric`)\cr variable data the statistics were calculated from. Used only to+ #' @keywords internal |
||
| 467 | +134 |
- #' find significant digits. In [analyze_vars] this comes from `.df_row` (see+ c_label_n <- function(df, |
||
| 468 | +135 |
- #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No+ labelstr, |
||
| 469 | +136 |
- #' column split is considered.+ .N_row) { # nolint
|
||
| 470 | -+ | |||
| 137 | +273x |
- #' @param x_stat (`string`)\cr string indicating the current statistical method used.+ label <- paste0(labelstr, " (N=", .N_row, ")") |
||
| 471 | -+ | |||
| 138 | +273x |
- #'+ in_rows( |
||
| 472 | -+ | |||
| 139 | +273x |
- #' @return A string that `rtables` prints in a table cell.+ .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)), |
||
| 473 | -+ | |||
| 140 | +273x |
- #'+ .formats = c(row_count = function(x, ...) "") |
||
| 474 | +141 |
- #' @details+ ) |
||
| 475 | +142 |
- #' The internal function is needed to work with `rtables` default structure for+ } |
||
| 476 | +143 |
- #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation.+ |
||
| 477 | +144 |
- #' It can be more than one element (e.g. for `.stats = "mean_sd"`).+ #' Content row function to add `alt_counts_df` row total to labels |
||
| 478 | +145 |
#' |
||
| 479 | +146 |
- #' @examples+ #' This takes the label of the latest row split level and adds the row total from `alt_counts_df` |
||
| 480 | +147 |
- #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4)+ #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df` |
||
| 481 | +148 |
- #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3]))+ #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`. |
||
| 482 | +149 |
#' |
||
| 483 | +150 |
- #' # x is the result coming into the formatting function -> res!!+ #' @inheritParams argument_convention |
||
| 484 | +151 |
- #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res)+ #' |
||
| 485 | +152 |
- #' format_auto(x_todo, "range")(x = range(x_todo))+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
||
| 486 | +153 |
- #' no_sc_x <- c(0.0000001, 1)+ #' |
||
| 487 | +154 |
- #' format_auto(no_sc_x, "range")(x = no_sc_x)+ #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead |
||
| 488 | +155 |
- #'+ #' of `alt_counts_df`. |
||
| 489 | +156 |
- #' @family formatting functions+ #' |
||
| 490 | +157 |
- #' @export+ #' @keywords internal |
||
| 491 | +158 |
- format_auto <- function(dt_var, x_stat) {
+ c_label_n_alt <- function(df, |
||
| 492 | -10x | +|||
| 159 | +
- function(x = "", ...) {
+ labelstr, |
|||
| 493 | -18x | +|||
| 160 | +
- checkmate::assert_numeric(x, min.len = 1)+ .alt_df_row) {
|
|||
| 494 | -18x | -
- checkmate::assert_numeric(dt_var, min.len = 1)- |
- ||
| 495 | -+ | 161 | +7x |
- # Defaults - they may be a param in the future+ N_row_alt <- nrow(.alt_df_row) # nolint |
| 496 | -18x | +162 | +7x |
- der_stats <- c(+ label <- paste0(labelstr, " (N=", N_row_alt, ")") |
| 497 | -18x | +163 | +7x |
- "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",+ in_rows( |
| 498 | -18x | +164 | +7x |
- "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi",+ .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)), |
| 499 | -18x | +165 | +7x |
- "median_ci"+ .formats = c(row_count = function(x, ...) "") |
| 500 | +166 |
- )+ ) |
||
| 501 | -18x | +|||
| 167 | +
- nonder_stats <- c("n", "range", "min", "max")
+ } |
|||
| 502 | +168 | |||
| 503 | +169 |
- # Safenet for miss-modifications- |
- ||
| 504 | -18x | -
- stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint+ #' Layout-creating function to add row total counts |
||
| 505 | -18x | +|||
| 170 | +
- checkmate::assert_choice(x_stat, c(der_stats, nonder_stats))+ #' |
|||
| 506 | +171 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 507 | +172 |
- # Finds the max number of digits in data+ #' |
||
| 508 | -18x | +|||
| 173 | +
- detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>%+ #' This works analogously to [rtables::add_colcounts()] but on the rows. This function |
|||
| 509 | -18x | +|||
| 174 | +
- max()+ #' is a wrapper for [rtables::summarize_row_groups()]. |
|||
| 510 | +175 |
-
+ #' |
||
| 511 | -18x | +|||
| 176 | +
- if (x_stat %in% der_stats) {
+ #' @inheritParams argument_convention |
|||
| 512 | -8x | +|||
| 177 | +
- detect_dig <- detect_dig + 1+ #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`) |
|||
| 513 | +178 |
- }+ #' or from `df` (`FALSE`). Defaults to `FALSE`. |
||
| 514 | +179 |
-
+ #' |
||
| 515 | +180 |
- # Render input+ #' @return A modified layout where the latest row split labels now have the row-wise |
||
| 516 | -18x | +|||
| 181 | +
- str_vals <- formatC(x, digits = detect_dig, format = "f")+ #' total counts (i.e. without column-based subsetting) attached in parentheses. |
|||
| 517 | -18x | +|||
| 182 | +
- def_fmt <- get_formats_from_stats(x_stat)[[x_stat]]+ #' |
|||
| 518 | -18x | +|||
| 183 | +
- str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]]+ #' @note Row count values are contained in these row count rows but are not displayed |
|||
| 519 | -18x | +|||
| 184 | +
- if (length(str_fmt) != length(str_vals)) {
+ #' so that they are not considered zero rows by default when pruning. |
|||
| 520 | -2x | +|||
| 185 | +
- stop(+ #' |
|||
| 521 | -2x | +|||
| 186 | +
- "Number of inserted values as result (", length(str_vals),
+ #' @examples |
|||
| 522 | -2x | +|||
| 187 | +
- ") is not the same as there should be in the default tern formats for ",+ #' basic_table() %>% |
|||
| 523 | -2x | +|||
| 188 | +
- x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ",+ #' split_cols_by("ARM") %>%
|
|||
| 524 | -2x | +|||
| 189 | +
- "See tern_default_formats to check all of them."+ #' add_colcounts() %>% |
|||
| 525 | +190 |
- )+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
||
| 526 | +191 |
- }+ #' add_rowcounts() %>% |
||
| 527 | +192 |
-
+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
|
||
| 528 | +193 |
- # Squashing them together+ #' build_table(DM) |
||
| 529 | -16x | +|||
| 194 | +
- inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]+ #' |
|||
| 530 | -16x | +|||
| 195 | +
- stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint+ #' @export |
|||
| 531 | +196 |
-
+ add_rowcounts <- function(lyt, alt_counts = FALSE) {
|
||
| 532 | -16x | +197 | +7x |
- out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
+ summarize_row_groups( |
| 533 | -16x | +198 | +7x |
- is_even <- seq_along(out) %% 2 == 0+ lyt, |
| 534 | -16x | +199 | +7x |
- out[is_even] <- str_vals+ cfun = if (alt_counts) c_label_n_alt else c_label_n |
| 535 | -16x | +|||
| 200 | +
- out[!is_even] <- inv_str_fmt+ ) |
|||
| 536 | +201 |
-
+ } |
||
| 537 | -16x | +|||
| 202 | +
- return(paste0(out, collapse = ""))+ |
|||
| 538 | +203 |
- }+ #' Obtain column indices |
||
| 539 | +204 |
- }+ #' |
||
| 540 | +205 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 541 | +206 |
- # Utility function that could be useful in general+ #' |
||
| 542 | +207 |
- str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
+ #' Helper function to extract column indices from a `VTableTree` for a given |
||
| 543 | -34x | +|||
| 208 | +
- regmatches(string, gregexpr(pattern, string), invert = invert)+ #' vector of column names. |
|||
| 544 | +209 |
- }+ #' |
||
| 545 | +210 |
-
+ #' @param table_tree (`VTableTree`)\cr `rtables` table object to extract the indices from. |
||
| 546 | +211 |
- # Helper function+ #' @param col_names (`character`)\cr vector of column names. |
||
| 547 | +212 |
- count_decimalplaces <- function(dec) {
+ #' |
||
| 548 | -161x | +|||
| 213 | +
- if (is.na(dec)) {
+ #' @return A vector of column indices. |
|||
| 549 | -6x | +|||
| 214 | +
- return(0)+ #' |
|||
| 550 | -155x | +|||
| 215 | +
- } else if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
+ #' @export |
|||
| 551 | -122x | +|||
| 216 | +
- nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]])+ h_col_indices <- function(table_tree, col_names) {
|
|||
| 552 | -+ | |||
| 217 | +1256x |
- } else {
+ checkmate::assert_class(table_tree, "VTableNodeInfo") |
||
| 553 | -33x | +218 | +1256x |
- return(0)+ checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE) |
| 554 | -+ | |||
| 219 | +1256x |
- }+ match(col_names, names(attr(col_info(table_tree), "cextra_args"))) |
||
| 555 | +220 |
} |
||
| 556 | +221 | |||
| 557 | +222 |
- #' Apply automatic formatting+ #' Labels or names of list elements |
||
| 558 | +223 |
#' |
||
| 559 | +224 |
- #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with+ #' Internal helper function for working with nested statistic function results which typically |
||
| 560 | +225 |
- #' the correct implementation of `format_auto` for the given statistics, data, and variable.+ #' don't have labels but names that we can use. |
||
| 561 | +226 |
#' |
||
| 562 | +227 |
- #' @inheritParams argument_convention+ #' @param x (`list`)\cr a list. |
||
| 563 | +228 |
- #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds+ #' |
||
| 564 | +229 |
- #' to an element in `.formats`, with matching names.+ #' @return A `character` vector with the labels or names for the list elements. |
||
| 565 | +230 |
#' |
||
| 566 | +231 |
#' @keywords internal |
||
| 567 | +232 |
- apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
+ labels_or_names <- function(x) {
|
||
| 568 | -524x | +233 | +190x |
- is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))+ checkmate::assert_multi_class(x, c("data.frame", "list"))
|
| 569 | -524x | +234 | +190x |
- if (any(is_auto_fmt)) {
+ labs <- sapply(x, obj_label) |
| 570 | -3x | +235 | +190x |
- auto_stats <- x_stats[is_auto_fmt]+ nams <- rlang::names2(x) |
| 571 | -3x | +236 | +190x |
- var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ label_is_null <- sapply(labs, is.null) |
| 572 | -3x | -
- .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df)- |
- ||
| 573 | -+ | 237 | +190x |
- }+ result <- unlist(ifelse(label_is_null, nams, labs)) |
| 574 | -524x | +238 | +190x |
- .formats+ return(result) |
| 575 | +239 |
} |
| 1 | -- |
- #' Confidence intervals for a difference of binomials- |
- ||
| 2 | +240 |
- #'+ |
||
| 3 | +241 |
- #' @description `r lifecycle::badge("experimental")`
+ #' Convert to `rtable` |
||
| 4 | +242 |
#' |
||
| 5 | +243 |
- #' Several confidence intervals for the difference between proportions.+ #' @description `r lifecycle::badge("stable")`
|
||
| 6 | +244 |
#' |
||
| 7 | -- |
- #' @name desctools_binom- |
- ||
| 8 | -- |
- NULL- |
- ||
| 9 | -- | - - | -||
| 10 | +245 |
- #' Recycle list of parameters+ #' This is a new generic function to convert objects to `rtable` tables. |
||
| 11 | +246 |
#' |
||
| 12 | -- |
- #' This function recycles all supplied elements to the maximal dimension.- |
- ||
| 13 | +247 |
- #'+ #' @param x (`data.frame`)\cr the object which should be converted to an `rtable`. |
||
| 14 | +248 |
- #' @param ... (`any`)\cr elements to recycle.+ #' @param ... additional arguments for methods. |
||
| 15 | +249 |
#' |
||
| 16 | +250 |
- #' @return A `list`.+ #' @return An `rtables` table object. Note that the concrete class will depend on the method used. |
||
| 17 | +251 |
#' |
||
| 18 | -- |
- #' @keywords internal- |
- ||
| 19 | +252 |
- #' @noRd+ #' @export |
||
| 20 | +253 |
- h_recycle <- function(...) {
- |
- ||
| 21 | -78x | -
- lst <- list(...)- |
- ||
| 22 | -78x | -
- maxdim <- max(lengths(lst))- |
- ||
| 23 | -78x | -
- res <- lapply(lst, rep, length.out = maxdim)- |
- ||
| 24 | -78x | -
- attr(res, "maxdim") <- maxdim+ as.rtable <- function(x, ...) { # nolint
|
||
| 25 | -78x | +254 | +3x |
- return(res)+ UseMethod("as.rtable", x)
|
| 26 | +255 |
} |
||
| 27 | +256 | |||
| 28 | +257 |
- #' @describeIn desctools_binom Several confidence intervals for the difference between proportions.+ #' @describeIn as.rtable Method for converting a `data.frame` that contains numeric columns to `rtable`. |
||
| 29 | +258 |
#' |
||
| 30 | +259 |
- #' @return A `matrix` of 3 values:+ #' @param format (`string` or `function`)\cr the format which should be used for the columns. |
||
| 31 | +260 |
- #' * `est`: estimate of proportion difference.+ #' |
||
| 32 | +261 |
- #' * `lwr.ci`: estimate of lower end of the confidence interval.+ #' @method as.rtable data.frame |
||
| 33 | +262 |
- #' * `upr.ci`: estimate of upper end of the confidence interval.+ #' |
||
| 34 | +263 |
- #'+ #' @examples |
||
| 35 | +264 |
- #' @keywords internal+ #' x <- data.frame( |
||
| 36 | +265 |
- desctools_binom <- function(x1,+ #' a = 1:10, |
||
| 37 | +266 |
- n1,+ #' b = rnorm(10) |
||
| 38 | +267 |
- x2,+ #' ) |
||
| 39 | +268 |
- n2,+ #' as.rtable(x) |
||
| 40 | +269 |
- conf.level = 0.95, # nolint+ #' |
||
| 41 | +270 |
- sides = c("two.sided", "left", "right"),
+ #' @export |
||
| 42 | +271 |
- method = c(+ as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
|
||
| 43 | -+ | |||
| 272 | +3x |
- "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"+ checkmate::assert_numeric(unlist(x)) |
||
| 44 | -+ | |||
| 273 | +2x |
- )) {
+ do.call( |
||
| 45 | -26x | +274 | +2x |
- if (missing(sides)) {
+ rtable, |
| 46 | -26x | +275 | +2x |
- sides <- match.arg(sides)+ c( |
| 47 | -+ | |||
| 276 | +2x |
- }+ list( |
||
| 48 | -26x | +277 | +2x |
- if (missing(method)) {
+ header = labels_or_names(x), |
| 49 | -1x | +278 | +2x |
- method <- match.arg(method)+ format = format |
| 50 | +279 |
- }+ ), |
||
| 51 | -26x | +280 | +2x |
- iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint
+ Map( |
| 52 | -26x | +281 | +2x |
- if (sides != "two.sided") {
- |
-
| 53 | -! | -
- conf.level <- 1 - 2 * (1 - conf.level) # nolint- |
- ||
| 54 | -- |
- }+ function(row, row_name) {
|
||
| 55 | -26x | +282 | +20x |
- alpha <- 1 - conf.level+ do.call( |
| 56 | -26x | +283 | +20x |
- kappa <- stats::qnorm(1 - alpha / 2)+ rrow, |
| 57 | -26x | +284 | +20x |
- p1_hat <- x1 / n1+ c(as.list(unname(row)), |
| 58 | -26x | +285 | +20x |
- p2_hat <- x2 / n2+ row.name = row_name |
| 59 | -26x | +|||
| 286 | +
- est <- p1_hat - p2_hat+ ) |
|||
| 60 | -26x | +|||
| 287 | +
- switch(method,+ ) |
|||
| 61 | -26x | +|||
| 288 | +
- wald = {
+ }, |
|||
| 62 | -4x | +289 | +2x |
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ row = as.data.frame(t(x)), |
| 63 | -4x | +290 | +2x |
- term2 <- kappa * sqrt(vd)+ row_name = rownames(x) |
| 64 | -4x | +|||
| 291 | +
- ci_lwr <- max(-1, est - term2)+ ) |
|||
| 65 | -4x | +|||
| 292 | +
- ci_upr <- min(1, est + term2)+ ) |
|||
| 66 | +293 |
- },+ ) |
||
| 67 | -26x | +|||
| 294 | +
- waldcc = {
+ } |
|||
| 68 | -6x | +|||
| 295 | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ |
|||
| 69 | -6x | +|||
| 296 | +
- term2 <- kappa * sqrt(vd)+ #' Split parameters |
|||
| 70 | -6x | +|||
| 297 | +
- term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)+ #' |
|||
| 71 | -6x | +|||
| 298 | +
- ci_lwr <- max(-1, est - term2)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 72 | -6x | +|||
| 299 | +
- ci_upr <- min(1, est + term2)+ #' |
|||
| 73 | +300 |
- },+ #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant |
||
| 74 | -26x | +|||
| 301 | +
- ac = {
+ #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to |
|||
| 75 | -2x | +|||
| 302 | +
- n1 <- n1 + 2+ #' specific analysis function. |
|||
| 76 | -2x | +|||
| 303 | +
- n2 <- n2 + 2+ #' |
|||
| 77 | -2x | +|||
| 304 | +
- x1 <- x1 + 1+ #' @param param (`vector`)\cr the parameter to be split. |
|||
| 78 | -2x | +|||
| 305 | +
- x2 <- x2 + 1+ #' @param value (`vector`)\cr the value used to split. |
|||
| 79 | -2x | +|||
| 306 | +
- p1_hat <- x1 / n1+ #' @param f (`list`)\cr the reference to make the split. |
|||
| 80 | -2x | +|||
| 307 | +
- p2_hat <- x2 / n2+ #' |
|||
| 81 | -2x | +|||
| 308 | +
- est1 <- p1_hat - p2_hat+ #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`. |
|||
| 82 | -2x | +|||
| 309 | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ #' |
|||
| 83 | -2x | +|||
| 310 | +
- term2 <- kappa * sqrt(vd)+ #' @examples |
|||
| 84 | -2x | +|||
| 311 | +
- ci_lwr <- max(-1, est1 - term2)+ #' f <- list( |
|||
| 85 | -2x | +|||
| 312 | +
- ci_upr <- min(1, est1 + term2)+ #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
|||
| 86 | +313 |
- },+ #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
||
| 87 | -26x | +|||
| 314 | +
- exact = {
+ #' ) |
|||
| 88 | -! | +|||
| 315 | +
- ci_lwr <- NA+ #' |
|||
| 89 | -! | +|||
| 316 | +
- ci_upr <- NA+ #' .stats <- c("pt_at_risk", "rate_diff")
|
|||
| 90 | +317 |
- },+ #' h_split_param(.stats, .stats, f = f) |
||
| 91 | -26x | +|||
| 318 | +
- score = {
+ #' |
|||
| 92 | -3x | +|||
| 319 | +
- w1 <- desctools_binomci(+ #' # $surv |
|||
| 93 | -3x | +|||
| 320 | +
- x = x1, n = n1, conf.level = conf.level,+ #' # [1] "pt_at_risk" |
|||
| 94 | -3x | +|||
| 321 | +
- method = "wilson"+ #' # |
|||
| 95 | +322 |
- )+ #' # $surv_diff |
||
| 96 | -3x | +|||
| 323 | +
- w2 <- desctools_binomci(+ #' # [1] "rate_diff" |
|||
| 97 | -3x | +|||
| 324 | +
- x = x2, n = n2, conf.level = conf.level,+ #' |
|||
| 98 | -3x | +|||
| 325 | +
- method = "wilson"+ #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
|
|||
| 99 | +326 |
- )+ #' h_split_param(.formats, names(.formats), f = f) |
||
| 100 | -3x | +|||
| 327 | +
- l1 <- w1[2]+ #' |
|||
| 101 | -3x | +|||
| 328 | +
- u1 <- w1[3]+ #' # $surv |
|||
| 102 | -3x | +|||
| 329 | +
- l2 <- w2[2]+ #' # pt_at_risk event_free_rate |
|||
| 103 | -3x | +|||
| 330 | +
- u2 <- w2[3]+ #' # "xx" "xxx" |
|||
| 104 | -3x | +|||
| 331 | +
- ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2)+ #' # |
|||
| 105 | -3x | +|||
| 332 | +
- ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2)+ #' # $surv_diff |
|||
| 106 | +333 |
- },+ #' # NULL |
||
| 107 | -26x | +|||
| 334 | +
- scorecc = {
+ #' |
|||
| 108 | -1x | +|||
| 335 | +
- w1 <- desctools_binomci(+ #' @export |
|||
| 109 | -1x | +|||
| 336 | +
- x = x1, n = n1, conf.level = conf.level,+ h_split_param <- function(param, |
|||
| 110 | -1x | +|||
| 337 | +
- method = "wilsoncc"+ value, |
|||
| 111 | +338 |
- )+ f) {
|
||
| 112 | -1x | +339 | +26x |
- w2 <- desctools_binomci(+ y <- lapply(f, function(x) param[value %in% x]) |
| 113 | -1x | +340 | +26x |
- x = x2, n = n2, conf.level = conf.level,+ lapply(y, function(x) if (length(x) == 0) NULL else x) |
| 114 | -1x | +|||
| 341 | +
- method = "wilsoncc"+ } |
|||
| 115 | +342 |
- )+ |
||
| 116 | -1x | +|||
| 343 | +
- l1 <- w1[2]+ #' Get selected statistics names |
|||
| 117 | -1x | +|||
| 344 | +
- u1 <- w1[3]+ #' |
|||
| 118 | -1x | +|||
| 345 | +
- l2 <- w2[2]+ #' Helper function to be used for creating `afun`. |
|||
| 119 | -1x | +|||
| 346 | +
- u2 <- w2[3]+ #' |
|||
| 120 | -1x | +|||
| 347 | +
- ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 + (u2 - p2_hat)^2))+ #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means |
|||
| 121 | -1x | +|||
| 348 | +
- ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat - l2)^2))+ #' in this context that all default statistics should be used. |
|||
| 122 | +349 |
- },+ #' @param all_stats (`character`)\cr all statistics which can be selected here potentially. |
||
| 123 | -26x | +|||
| 350 | +
- mee = {
+ #' |
|||
| 124 | -1x | +|||
| 351 | +
- .score <- function(p1, n1, p2, n2, dif) {
+ #' @return A `character` vector with the selected statistics. |
|||
| 125 | -! | +|||
| 352 | +
- if (dif > 1) dif <- 1+ #' |
|||
| 126 | -! | +|||
| 353 | +
- if (dif < -1) dif <- -1+ #' @keywords internal |
|||
| 127 | -24x | +|||
| 354 | +
- diff <- p1 - p2 - dif+ afun_selected_stats <- function(.stats, all_stats) {
|
|||
| 128 | -24x | +355 | +2x |
- if (abs(diff) == 0) {
+ checkmate::assert_character(.stats, null.ok = TRUE) |
| 129 | -! | +|||
| 356 | +2x |
- res <- 0+ checkmate::assert_character(all_stats) |
||
| 130 | -+ | |||
| 357 | +2x |
- } else {
+ if (is.null(.stats)) {
|
||
| 131 | -24x | +358 | +1x |
- t <- n2 / n1+ all_stats |
| 132 | -24x | +|||
| 359 | +
- a <- 1 + t+ } else {
|
|||
| 133 | -24x | +360 | +1x |
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ intersect(.stats, all_stats) |
| 134 | -24x | +|||
| 361 | +
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ } |
|||
| 135 | -24x | +|||
| 362 | +
- d <- -p1 * dif * (1 + dif)+ } |
|||
| 136 | -24x | +|||
| 363 | +
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ |
|||
| 137 | -24x | +|||
| 364 | +
- if (abs(v) < .Machine$double.eps) v <- 0+ #' Add variable labels to top left corner in table |
|||
| 138 | -24x | +|||
| 365 | +
- s <- sqrt((b / a / 3)^2 - c / a / 3)+ #' |
|||
| 139 | -24x | +|||
| 366 | +
- u <- ifelse(v > 0, 1, -1) * s+ #' @description `r lifecycle::badge("stable")`
|
|||
| 140 | -24x | +|||
| 367 | +
- w <- (3.141592654 + acos(v / u^3)) / 3+ #' |
|||
| 141 | -24x | +|||
| 368 | +
- p1d <- 2 * u * cos(w) - b / a / 3+ #' Helper layout-creating function to append the variable labels of a given variables vector |
|||
| 142 | -24x | +|||
| 369 | +
- p2d <- p1d - dif+ #' from a given dataset in the top left corner. If a variable label is not found then the |
|||
| 143 | -24x | +|||
| 370 | +
- n <- n1 + n2+ #' variable name itself is used instead. Multiple variable labels are concatenated with slashes. |
|||
| 144 | -24x | +|||
| 371 | +
- res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2)+ #' |
|||
| 145 | +372 |
- }+ #' @inheritParams argument_convention |
||
| 146 | -24x | +|||
| 373 | +
- return(sqrt(res))+ #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`. |
|||
| 147 | +374 |
- }+ #' @param indent (`integer(1)`)\cr non-negative number of nested indent space, default to 0L which means no indent. |
||
| 148 | -1x | +|||
| 375 | +
- pval <- function(delta) {
+ #' 1L means two spaces indent, 2L means four spaces indent and so on. |
|||
| 149 | -24x | +|||
| 376 | +
- z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta)+ #' |
|||
| 150 | -24x | +|||
| 377 | +
- 2 * min(stats::pnorm(z), 1 - stats::pnorm(z))+ #' @return A modified layout with the new variable label(s) added to the top-left material. |
|||
| 151 | +378 |
- }+ #' |
||
| 152 | -1x | +|||
| 379 | +
- ci_lwr <- max(-1, stats::uniroot(function(delta) {
+ #' @note This is not an optimal implementation of course, since we are using here the data set |
|||
| 153 | -12x | +|||
| 380 | +
- pval(delta) - alpha+ #' itself during the layout creation. When we have a more mature `rtables` implementation then |
|||
| 154 | -1x | +|||
| 381 | +
- }, interval = c(-1 + 1e-06, est - 1e-06))$root)+ #' this will also be improved or not necessary anymore. |
|||
| 155 | -1x | +|||
| 382 | +
- ci_upr <- min(1, stats::uniroot(function(delta) {
+ #' |
|||
| 156 | -12x | +|||
| 383 | +
- pval(delta) - alpha+ #' @examples |
|||
| 157 | -1x | +|||
| 384 | +
- }, interval = c(est + 1e-06, 1 - 1e-06))$root)+ #' lyt <- basic_table() %>% |
|||
| 158 | +385 |
- },+ #' split_cols_by("ARM") %>%
|
||
| 159 | -26x | +|||
| 386 | +
- blj = {
+ #' add_colcounts() %>% |
|||
| 160 | -1x | +|||
| 387 | +
- p1_dash <- (x1 + 0.5) / (n1 + 1)+ #' split_rows_by("SEX") %>%
|
|||
| 161 | -1x | +|||
| 388 | +
- p2_dash <- (x2 + 0.5) / (n2 + 1)+ #' append_varlabels(DM, "SEX") %>% |
|||
| 162 | -1x | +|||
| 389 | +
- vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2+ #' analyze("AGE", afun = mean) %>%
|
|||
| 163 | -1x | +|||
| 390 | +
- term2 <- kappa * sqrt(vd)+ #' append_varlabels(DM, "AGE", indent = 1) |
|||
| 164 | -1x | +|||
| 391 | +
- est_dash <- p1_dash - p2_dash+ #' build_table(lyt, DM) |
|||
| 165 | -1x | +|||
| 392 | +
- ci_lwr <- max(-1, est_dash - term2)+ #' |
|||
| 166 | -1x | +|||
| 393 | +
- ci_upr <- min(1, est_dash + term2)+ #' lyt <- basic_table() %>% |
|||
| 167 | +394 |
- },+ #' split_cols_by("ARM") %>%
|
||
| 168 | -26x | +|||
| 395 | +
- ha = {
+ #' split_rows_by("SEX") %>%
|
|||
| 169 | -5x | +|||
| 396 | +
- term2 <- 1 /+ #' analyze("AGE", afun = mean) %>%
|
|||
| 170 | -5x | +|||
| 397 | +
- (2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1))+ #' append_varlabels(DM, c("SEX", "AGE"))
|
|||
| 171 | -5x | +|||
| 398 | +
- ci_lwr <- max(-1, est - term2)+ #' build_table(lyt, DM) |
|||
| 172 | -5x | +|||
| 399 | +
- ci_upr <- min(1, est + term2)+ #' |
|||
| 173 | +400 |
- },+ #' @export |
||
| 174 | -26x | +|||
| 401 | +
- mn = {
+ append_varlabels <- function(lyt, df, vars, indent = 0L) {
|
|||
| 175 | -1x | +402 | +3x |
- .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
+ if (checkmate::test_flag(indent)) {
|
| 176 | -2x | +|||
| 403 | +! |
- p1 <- x1 / n1+ warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
|
||
| 177 | -2x | +|||
| 404 | +! |
- p2 <- x2 / n2+ indent <- as.integer(indent) |
||
| 178 | -2x | +|||
| 405 | +
- p_hat <- p1 - p2+ } |
|||
| 179 | -2x | +|||
| 406 | +
- dp <- 1 + ifelse(lower, 1, -1) * p_hat+ |
|||
| 180 | -2x | +407 | +3x |
- i <- 1+ checkmate::assert_data_frame(df) |
| 181 | -2x | +408 | +3x |
- while (i <= 50) {
+ checkmate::assert_character(vars) |
| 182 | -46x | +409 | +3x |
- dp <- 0.5 * dp+ checkmate::assert_count(indent)+ |
+
| 410 | ++ | + | ||
| 183 | -46x | +411 | +3x |
- y <- p_hat + ifelse(lower, -1, 1) * dp+ lab <- formatters::var_labels(df[vars], fill = TRUE) |
| 184 | -46x | +412 | +3x |
- score <- .score(p1, n1, p2, n2, y)+ lab <- paste(lab, collapse = " / ") |
| 185 | -46x | +413 | +3x |
- if (score < z) {
+ space <- paste(rep(" ", indent * 2), collapse = "")
|
| 186 | -20x | +414 | +3x |
- p_hat <- y+ lab <- paste0(space, lab) |
| 187 | +415 |
- }+ |
||
| 188 | -46x | +416 | +3x |
- if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
+ append_topleft(lyt, lab) |
| 189 | -2x | +|||
| 417 | +
- (break)()+ } |
|||
| 190 | +418 |
- } else {
+
|
||
| 191 | -44x | +|||
| 419 | +
- i <- i + 1+ #' Default string replacement for `NA` values |
|||
| 192 | +420 |
- }+ #' |
||
| 193 | +421 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 194 | -2x | +|||
| 422 | +
- return(y)+ #' |
|||
| 195 | +423 |
- }- |
- ||
| 196 | -1x | -
- .score <- function(p1, n1, p2, n2, dif) {
- |
- ||
| 197 | -46x | -
- diff <- p1 - p2 - dif- |
- ||
| 198 | -46x | -
- if (abs(diff) == 0) {
- |
- ||
| 199 | -! | -
- res <- 0+ #' The default string used to represent `NA` values. This value is used as the default |
||
| 200 | +424 |
- } else {
- |
- ||
| 201 | -46x | -
- t <- n2 / n1- |
- ||
| 202 | -46x | -
- a <- 1 + t- |
- ||
| 203 | -46x | -
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))- |
- ||
| 204 | -46x | -
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2- |
- ||
| 205 | -46x | -
- d <- -p1 * dif * (1 + dif)- |
- ||
| 206 | -46x | -
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2- |
- ||
| 207 | -46x | -
- s <- sqrt((b / a / 3)^2 - c / a / 3)- |
- ||
| 208 | -46x | -
- u <- ifelse(v > 0, 1, -1) * s- |
- ||
| 209 | -46x | -
- w <- (3.141592654 + acos(v / u^3)) / 3- |
- ||
| 210 | -46x | -
- p1d <- 2 * u * cos(w) - b / a / 3- |
- ||
| 211 | -46x | -
- p2d <- p1d - dif- |
- ||
| 212 | -46x | -
- n <- n1 + n2- |
- ||
| 213 | -46x | -
- var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) * n / (n - 1)- |
- ||
| 214 | -46x | -
- res <- diff^2 / var+ #' value for the `na_str` argument throughout the `tern` package, and printed in place |
||
| 215 | +425 |
- }- |
- ||
| 216 | -46x | -
- return(res)+ #' of `NA` values in output tables. If not specified for each `tern` function by the user |
||
| 217 | +426 |
- }- |
- ||
| 218 | -1x | -
- z <- stats::qchisq(conf.level, 1)- |
- ||
| 219 | -1x | -
- ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))- |
- ||
| 220 | -1x | -
- ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE))+ #' via the `na_str` argument, or in the R environment options via [set_default_na_str()], |
||
| 221 | +427 |
- },- |
- ||
| 222 | -26x | -
- beal = {
- |
- ||
| 223 | -! | -
- a <- p1_hat + p2_hat+ #' then `NA` is used. |
||
| 224 | -! | +|||
| 428 | +
- b <- p1_hat - p2_hat+ #' |
|||
| 225 | -! | +|||
| 429 | +
- u <- ((1 / n1) + (1 / n2)) / 4+ #' @param na_str (`string`)\cr single string value to set in the R environment options as |
|||
| 226 | -! | +|||
| 430 | +
- v <- ((1 / n1) - (1 / n2)) / 4+ #' the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the
|
|||
| 227 | -! | +|||
| 431 | +
- V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint+ #' current value set in the R environment (defaults to `NULL` if not set). |
|||
| 228 | -! | +|||
| 432 | +
- z <- stats::qchisq(p = 1 - alpha / 2, df = 1)+ #' |
|||
| 229 | -! | +|||
| 433 | +
- A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint+ #' @name default_na_str |
|||
| 230 | -! | +|||
| 434 | +
- B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint+ NULL |
|||
| 231 | -! | +|||
| 435 | +
- ci_lwr <- max(-1, B - A / (1 + z * u))+ |
|||
| 232 | -! | +|||
| 436 | +
- ci_upr <- min(1, B + A / (1 + z * u))+ #' @describeIn default_na_str Accessor for default `NA` value replacement string. |
|||
| 233 | +437 |
- },+ #' |
||
| 234 | -26x | +|||
| 438 | +
- hal = {
+ #' @return |
|||
| 235 | -1x | +|||
| 439 | +
- psi <- (p1_hat + p2_hat) / 2+ #' * `default_na_str` returns the current value if an R environment option has been set |
|||
| 236 | -1x | +|||
| 440 | +
- u <- (1 / n1 + 1 / n2) / 4+ #' for `"tern_default_na_str"`, or `NA_character_` otherwise. |
|||
| 237 | -1x | +|||
| 441 | +
- v <- (1 / n1 - 1 / n2) / 4+ #' |
|||
| 238 | -1x | +|||
| 442 | +
- z <- kappa+ #' @examples |
|||
| 239 | -1x | +|||
| 443 | +
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ #' # Default settings |
|||
| 240 | -1x | +|||
| 444 | +
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ #' default_na_str() |
|||
| 241 | -1x | +|||
| 445 | +
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ #' getOption("tern_default_na_str")
|
|||
| 242 | -1x | +|||
| 446 | +
- c(theta + w, theta - w)+ #' |
|||
| 243 | -1x | +|||
| 447 | +
- ci_lwr <- max(-1, theta - w)+ #' # Set custom value |
|||
| 244 | -1x | +|||
| 448 | +
- ci_upr <- min(1, theta + w)+ #' set_default_na_str("<Missing>")
|
|||
| 245 | +449 |
- },+ #' |
||
| 246 | -26x | +|||
| 450 | +
- jp = {
+ #' # Settings after value has been set |
|||
| 247 | -1x | +|||
| 451 | +
- psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1))+ #' default_na_str() |
|||
| 248 | -1x | +|||
| 452 | +
- u <- (1 / n1 + 1 / n2) / 4+ #' getOption("tern_default_na_str")
|
|||
| 249 | -1x | +|||
| 453 | +
- v <- (1 / n1 - 1 / n2) / 4+ #' |
|||
| 250 | -1x | +|||
| 454 | +
- z <- kappa+ #' @export |
|||
| 251 | -1x | +|||
| 455 | +
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ default_na_str <- function() {
|
|||
| 252 | -1x | +456 | +320x |
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ getOption("tern_default_na_str", default = NA_character_)
|
| 253 | -1x | +|||
| 457 | +
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ } |
|||
| 254 | -1x | +|||
| 458 | +
- c(theta + w, theta - w)+ |
|||
| 255 | -1x | +|||
| 459 | +
- ci_lwr <- max(-1, theta - w)+ #' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the |
|||
| 256 | -1x | +|||
| 460 | +
- ci_upr <- min(1, theta + w)+ #' option `"tern_default_na_str"` within the R environment. |
|||
| 257 | +461 |
- },+ #' |
||
| 258 | +462 |
- )+ #' @return |
||
| 259 | -26x | +|||
| 463 | +
- ci <- c(+ #' * `set_default_na_str` has no return value. |
|||
| 260 | -26x | +|||
| 464 | +
- est = est, lwr.ci = min(ci_lwr, ci_upr),+ #' |
|||
| 261 | -26x | +|||
| 465 | +
- upr.ci = max(ci_lwr, ci_upr)+ #' @export |
|||
| 262 | +466 |
- )+ set_default_na_str <- function(na_str) {
|
||
| 263 | -26x | -
- if (sides == "left") {
- |
- ||
| 264 | -! | +467 | +3x |
- ci[3] <- 1+ checkmate::assert_character(na_str, len = 1, null.ok = TRUE) |
| 265 | -26x | +468 | +3x |
- } else if (sides == "right") {
+ options("tern_default_na_str" = na_str)
|
| 266 | -! | +|||
| 469 | +
- ci[2] <- -1+ } |
| 267 | +1 |
- }+ #' Custom split functions |
||
| 268 | -26x | +|||
| 2 | +
- return(ci)+ #' |
|||
| 269 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 270 | -26x | +|||
| 4 | +
- method <- match.arg(arg = method, several.ok = TRUE)+ #' |
|||
| 271 | -26x | +|||
| 5 | +
- sides <- match.arg(arg = sides, several.ok = TRUE)+ #' Collection of useful functions that are expanding on the core list of functions |
|||
| 272 | -26x | +|||
| 6 | +
- lst <- h_recycle(+ #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()] |
|||
| 273 | -26x | +|||
| 7 | +
- x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level,+ #' for more information on how to make a custom split function. All these functions |
|||
| 274 | -26x | +|||
| 8 | +
- sides = sides, method = method+ #' work with [rtables::split_rows_by()] argument `split_fun` to modify the way the split |
|||
| 275 | +9 |
- )+ #' happens. For other split functions, consider consulting [`rtables::split_funcs`]. |
||
| 276 | -26x | +|||
| 10 | +
- res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
+ #' |
|||
| 277 | -26x | +|||
| 11 | +
- iBinomDiffCI(+ #' @seealso [rtables::make_split_fun()] |
|||
| 278 | -26x | +|||
| 12 | +
- x1 = lst$x1[i],+ #' |
|||
| 279 | -26x | +|||
| 13 | +
- n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i],+ #' @name utils_split_funs |
|||
| 280 | -26x | +|||
| 14 | +
- sides = lst$sides[i], method = lst$method[i]+ NULL |
|||
| 281 | +15 |
- )+ |
||
| 282 | +16 |
- }))+ #' @describeIn utils_split_funs Split function to place reference group facet at a specific position |
||
| 283 | -26x | +|||
| 17 | +
- lgn <- h_recycle(x1 = if (is.null(names(x1))) {
+ #' during post-processing stage. |
|||
| 284 | -26x | +|||
| 18 | +
- paste("x1", seq_along(x1), sep = ".")
+ #' |
|||
| 285 | +19 |
- } else {
+ #' @param position (`string` or `integer`)\cr position to use for the reference group facet. Can be `"first"`, |
||
| 286 | -! | +|||
| 20 | +
- names(x1)+ #' `"last"`, or a specific position. |
|||
| 287 | -26x | +|||
| 21 | +
- }, n1 = if (is.null(names(n1))) {
+ #' |
|||
| 288 | -26x | +|||
| 22 | +
- paste("n1", seq_along(n1), sep = ".")
+ #' @return |
|||
| 289 | +23 |
- } else {
+ #' * `ref_group_position()` returns an utility function that puts the reference group |
||
| 290 | -! | +|||
| 24 | +
- names(n1)+ #' as first, last or at a certain position and needs to be assigned to `split_fun`. |
|||
| 291 | -26x | +|||
| 25 | +
- }, x2 = if (is.null(names(x2))) {
+ #' |
|||
| 292 | -26x | +|||
| 26 | +
- paste("x2", seq_along(x2), sep = ".")
+ #' @examples |
|||
| 293 | +27 |
- } else {
+ #' library(dplyr) |
||
| 294 | -! | +|||
| 28 | +
- names(x2)+ #' |
|||
| 295 | -26x | +|||
| 29 | +
- }, n2 = if (is.null(names(n2))) {
+ #' dat <- data.frame( |
|||
| 296 | -26x | +|||
| 30 | +
- paste("n2", seq_along(n2), sep = ".")
+ #' x = factor(letters[1:5], levels = letters[5:1]), |
|||
| 297 | +31 |
- } else {
+ #' y = 1:5 |
||
| 298 | -! | +|||
| 32 | +
- names(n2)+ #' ) |
|||
| 299 | -26x | +|||
| 33 | +
- }, conf.level = conf.level, sides = sides, method = method)+ #' |
|||
| 300 | -26x | +|||
| 34 | +
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ #' # With rtables layout functions |
|||
| 301 | -182x | +|||
| 35 | +
- length(unique(x)) !=+ #' basic_table() %>% |
|||
| 302 | -182x | +|||
| 36 | +
- 1+ #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
|
|||
| 303 | -26x | +|||
| 37 | +
- })]), 1, paste, collapse = ":")+ #' analyze("y") %>%
|
|||
| 304 | -26x | +|||
| 38 | +
- rownames(res) <- xn+ #' build_table(dat) |
|||
| 305 | -26x | +|||
| 39 | +
- return(res)+ #' |
|||
| 306 | +40 |
- }+ #' # With tern layout funcitons |
||
| 307 | +41 |
-
+ #' adtte_f <- tern_ex_adtte %>% |
||
| 308 | +42 |
- #' @describeIn desctools_binom Compute confidence intervals for binomial proportions.+ #' filter(PARAMCD == "OS") %>% |
||
| 309 | +43 |
- #'+ #' mutate( |
||
| 310 | +44 |
- #' @param x (`integer(1)`)\cr number of successes.+ #' AVAL = day2month(AVAL), |
||
| 311 | +45 |
- #' @param n (`integer(1)`)\cr number of trials.+ #' is_event = CNSR == 0 |
||
| 312 | +46 |
- #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.+ #' ) |
||
| 313 | +47 |
- #' @param sides (`string`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default),+ #' |
||
| 314 | +48 |
- #' `"left"`, or `"right"`.+ #' basic_table() %>% |
||
| 315 | +49 |
- #' @param method (`string`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`,+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
|
||
| 316 | +50 |
- #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`,+ #' add_colcounts() %>% |
||
| 317 | +51 |
- #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`.+ #' surv_time( |
||
| 318 | +52 |
- #'+ #' vars = "AVAL", |
||
| 319 | +53 |
- #' @return A `matrix` with 3 columns containing:+ #' var_labels = "Survival Time (Months)", |
||
| 320 | +54 |
- #' * `est`: estimate of proportion difference.+ #' is_event = "is_event", |
||
| 321 | +55 |
- #' * `lwr.ci`: lower end of the confidence interval.+ #' ) %>% |
||
| 322 | +56 |
- #' * `upr.ci`: upper end of the confidence interval.+ #' build_table(df = adtte_f) |
||
| 323 | +57 |
#' |
||
| 324 | +58 |
- #' @keywords internal+ #' basic_table() %>% |
||
| 325 | +59 |
- desctools_binomci <- function(x,+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>% |
||
| 326 | +60 |
- n,+ #' add_colcounts() %>% |
||
| 327 | +61 |
- conf.level = 0.95, # nolint+ #' surv_time( |
||
| 328 | +62 |
- sides = c("two.sided", "left", "right"),
+ #' vars = "AVAL", |
||
| 329 | +63 |
- method = c(+ #' var_labels = "Survival Time (Months)", |
||
| 330 | +64 |
- "wilson", "wald", "waldcc", "agresti-coull",+ #' is_event = "is_event", |
||
| 331 | +65 |
- "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",+ #' ) %>% |
||
| 332 | +66 |
- "clopper-pearson", "arcsine", "logit", "witting", "pratt",+ #' build_table(df = adtte_f) |
||
| 333 | +67 |
- "midp", "lik", "blaker"+ #' |
||
| 334 | +68 |
- ),+ #' @export |
||
| 335 | +69 |
- rand = 123,+ ref_group_position <- function(position = "first") {
|
||
| 336 | -+ | |||
| 70 | +20x |
- tol = 1e-05) {
+ make_split_fun( |
||
| 337 | -26x | +71 | +20x |
- if (missing(method)) {
+ post = list( |
| 338 | -1x | +72 | +20x |
- method <- "wilson"+ function(splret, spl, fulldf) {
|
| 339 | -+ | |||
| 73 | +57x |
- }+ if (!"ref_group_value" %in% methods::slotNames(spl)) {
|
||
| 340 | -26x | +74 | +1x |
- if (missing(sides)) {
+ stop("Reference group is undefined.")
|
| 341 | -25x | +|||
| 75 | +
- sides <- "two.sided"+ } |
|||
| 342 | +76 |
- }+ |
||
| 343 | -26x | +77 | +56x |
- iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint
+ spl_var <- rtables:::spl_payload(spl) |
| 344 | -26x | +78 | +56x |
- method = c(+ fulldf[[spl_var]] <- factor(fulldf[[spl_var]]) |
| 345 | -26x | +79 | +56x |
- "wilson", "wilsoncc", "wald",+ init_lvls <- levels(fulldf[[spl_var]]) |
| 346 | -26x | +|||
| 80 | +
- "waldcc", "agresti-coull", "jeffreys", "modified wilson",+ |
|||
| 347 | -26x | +81 | +56x |
- "modified jeffreys", "clopper-pearson", "arcsine", "logit",+ if (!all(names(splret$values) %in% init_lvls)) {
|
| 348 | -26x | +|||
| 82 | +! |
- "witting", "pratt", "midp", "lik", "blaker"+ stop("This split function does not work with combination facets.")
|
||
| 349 | +83 |
- ),+ } |
||
| 350 | -26x | +|||
| 84 | +
- rand = 123,+ |
|||
| 351 | -26x | +85 | +56x |
- tol = 1e-05) {
+ ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl)) |
| 352 | -26x | +86 | +56x |
- if (length(x) != 1) {
+ pos_choices <- c("first", "last")
|
| 353 | -! | +|||
| 87 | +56x |
- stop("'x' has to be of length 1 (number of successes)")
+ if (checkmate::test_choice(position, pos_choices) && position == "first") {
|
||
| 354 | -- |
- }+ | ||
| 88 | +41x | +
+ pos <- 0 |
||
| 355 | -26x | +89 | +15x |
- if (length(n) != 1) {
+ } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
|
| 356 | -! | +|||
| 90 | +12x |
- stop("'n' has to be of length 1 (number of trials)")
+ pos <- length(init_lvls) |
||
| 357 | -+ | |||
| 91 | +3x |
- }+ } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
|
||
| 358 | -26x | +92 | +3x |
- if (length(conf.level) != 1) {
+ pos <- position - 1+ |
+
| 93 | ++ |
+ } else {
|
||
| 359 | +94 | ! |
- stop("'conf.level' has to be of length 1 (confidence level)")
+ stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
|
|
| 360 | +95 |
- }+ }+ |
+ ||
| 96 | ++ | + | ||
| 361 | -26x | +97 | +56x |
- if (conf.level < 0.5 || conf.level > 1) {
+ reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos) |
| 362 | -! | +|||
| 98 | +56x |
- stop("'conf.level' has to be in [0.5, 1]")
+ ord <- match(reord_lvls, names(splret$values)) |
||
| 363 | +99 |
- }+ |
||
| 364 | -26x | +100 | +56x |
- sides <- match.arg(sides, choices = c(+ make_split_result( |
| 365 | -26x | +101 | +56x |
- "two.sided", "left",+ splret$values[ord], |
| 366 | -26x | +102 | +56x |
- "right"+ splret$datasplit[ord], |
| 367 | -26x | +103 | +56x |
- ), several.ok = FALSE)+ splret$labels[ord] |
| 368 | -26x | +|||
| 104 | +
- if (sides != "two.sided") {
+ ) |
|||
| 369 | -1x | +|||
| 105 | +
- conf.level <- 1 - 2 * (1 - conf.level) # nolint+ } |
|||
| 370 | +106 |
- }+ ) |
||
| 371 | -26x | +|||
| 107 | +
- alpha <- 1 - conf.level+ ) |
|||
| 372 | -26x | +|||
| 108 | +
- kappa <- stats::qnorm(1 - alpha / 2)+ } |
|||
| 373 | -26x | +|||
| 109 | +
- p_hat <- x / n+ |
|||
| 374 | -26x | +|||
| 110 | +
- q_hat <- 1 - p_hat+ #' @describeIn utils_split_funs Split function to change level order based on an `integer` |
|||
| 375 | -26x | +|||
| 111 | +
- est <- p_hat+ #' vector or a `character` vector that represent the split variable's factor levels. |
|||
| 376 | -26x | +|||
| 112 | +
- switch(match.arg(arg = method, choices = c(+ #' |
|||
| 377 | -26x | +|||
| 113 | +
- "wilson",+ #' @param order (`character` or `numeric`)\cr vector of ordering indices for the split facets. |
|||
| 378 | -26x | +|||
| 114 | +
- "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys",+ #' |
|||
| 379 | -26x | +|||
| 115 | +
- "modified wilson", "modified jeffreys", "clopper-pearson",+ #' @return |
|||
| 380 | -26x | +|||
| 116 | +
- "arcsine", "logit", "witting", "pratt", "midp", "lik",+ #' * `level_order()` returns an utility function that changes the original levels' order, |
|||
| 381 | -26x | +|||
| 117 | +
- "blaker"+ #' depending on input `order` and split levels. |
|||
| 382 | +118 |
- )),+ #' |
||
| 383 | -26x | +|||
| 119 | +
- wald = {
+ #' @examples |
|||
| 384 | -1x | +|||
| 120 | +
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ #' # level_order -------- |
|||
| 385 | -1x | +|||
| 121 | +
- ci_lwr <- max(0, p_hat - term2)+ #' # Even if default would bring ref_group first, the original order puts it last |
|||
| 386 | -1x | +|||
| 122 | +
- ci_upr <- min(1, p_hat + term2)+ #' basic_table() %>% |
|||
| 387 | +123 |
- },+ #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
|
||
| 388 | -26x | +|||
| 124 | +
- waldcc = {
+ #' analyze("Sepal.Length") %>%
|
|||
| 389 | -1x | +|||
| 125 | +
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ #' build_table(iris) |
|||
| 390 | -1x | +|||
| 126 | +
- term2 <- term2 + 1 / (2 * n)+ #' |
|||
| 391 | -1x | +|||
| 127 | +
- ci_lwr <- max(0, p_hat - term2)+ #' # character vector |
|||
| 392 | -1x | +|||
| 128 | +
- ci_upr <- min(1, p_hat + term2)+ #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)]) |
|||
| 393 | +129 |
- },+ #' basic_table() %>% |
||
| 394 | -26x | +|||
| 130 | +
- wilson = {
+ #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
|
|||
| 395 | -8x | +|||
| 131 | +
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ #' analyze("Sepal.Length") %>%
|
|||
| 396 | -8x | +|||
| 132 | +
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ #' build_table(iris) |
|||
| 397 | -8x | +|||
| 133 | +
- ci_lwr <- max(0, term1 - term2)+ #' |
|||
| 398 | -8x | +|||
| 134 | +
- ci_upr <- min(1, term1 + term2)+ #' @export |
|||
| 399 | +135 |
- },+ level_order <- function(order) {
|
||
| 400 | -26x | +136 | +2x |
- wilsoncc = {
+ make_split_fun( |
| 401 | -3x | +137 | +2x |
- lci <- (+ post = list( |
| 402 | -3x | +138 | +2x |
- 2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1))+ function(splret, spl, fulldf) {
|
| 403 | -3x | +139 | +4x |
- ) / (2 * (n + kappa^2))+ if (checkmate::test_integerish(order)) {
|
| 404 | -3x | +140 | +1x |
- uci <- (+ checkmate::assert_integerish(order, lower = 1, upper = length(splret$values)) |
| 405 | -3x | +141 | +1x |
- 2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1))+ ord <- order+ |
+
| 142 | ++ |
+ } else {
|
||
| 406 | +143 | 3x |
- ) / (2 * (n + kappa^2))+ checkmate::assert_character(order, len = length(splret$values)) |
|
| 407 | +144 | 3x |
- ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))+ checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE) |
|
| 408 | +145 | 3x |
- ci_upr <- min(1, ifelse(p_hat == 1, 1, uci))+ ord <- match(order, names(splret$values)) |
|
| 409 | +146 |
- },+ } |
||
| 410 | -26x | +147 | +4x |
- `agresti-coull` = {
+ make_split_result( |
| 411 | -1x | +148 | +4x |
- x_tilde <- x + kappa^2 / 2+ splret$values[ord], |
| 412 | -1x | +149 | +4x |
- n_tilde <- n + kappa^2+ splret$datasplit[ord], |
| 413 | -1x | +150 | +4x |
- p_tilde <- x_tilde / n_tilde+ splret$labels[ord] |
| 414 | -1x | +|||
| 151 | +
- q_tilde <- 1 - p_tilde+ ) |
|||
| 415 | -1x | +|||
| 152 | +
- est <- p_tilde+ } |
|||
| 416 | -1x | +|||
| 153 | +
- term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ ) |
|||
| 417 | -1x | +|||
| 154 | +
- ci_lwr <- max(0, p_tilde - term2)+ ) |
|||
| 418 | -1x | +|||
| 155 | +
- ci_upr <- min(1, p_tilde + term2)+ } |
| 419 | +1 |
- },+ #' Tabulate biomarker effects on binary response by subgroup |
||
| 420 | -26x | +|||
| 2 | +
- jeffreys = {
+ #' |
|||
| 421 | -1x | +|||
| 3 | +
- if (x == 0) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 422 | -! | +|||
| 4 | +
- ci_lwr <- 0+ #' |
|||
| 423 | +5 |
- } else {
+ #' The [tabulate_rsp_biomarkers()] function creates a layout element to tabulate the estimated biomarker effects on a |
||
| 424 | -1x | +|||
| 6 | +
- ci_lwr <- stats::qbeta(+ #' binary response endpoint across subgroups, returning statistics including response rate and odds ratio for each |
|||
| 425 | -1x | +|||
| 7 | +
- alpha / 2,+ #' population subgroup. The table is created from `df`, a list of data frames returned by [extract_rsp_biomarkers()], |
|||
| 426 | -1x | +|||
| 8 | +
- x + 0.5, n - x + 0.5+ #' with the statistics to include specified via the `vars` parameter. |
|||
| 427 | +9 |
- )+ #' |
||
| 428 | +10 |
- }+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 429 | -1x | +|||
| 11 | +
- if (x == n) {
+ #' |
|||
| 430 | -! | +|||
| 12 | +
- ci_upr <- 1+ #' @inheritParams argument_convention |
|||
| 431 | +13 |
- } else {
+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
||
| 432 | -1x | +|||
| 14 | +
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)+ #' [extract_rsp_biomarkers()]. |
|||
| 433 | +15 |
- }+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 434 | +16 |
- },+ #' * `n_tot`: Total number of patients per group. |
||
| 435 | -26x | +|||
| 17 | +
- `modified wilson` = {
+ #' * `n_rsp`: Total number of responses per group. |
|||
| 436 | -1x | +|||
| 18 | +
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ #' * `prop`: Total response proportion per group. |
|||
| 437 | -1x | +|||
| 19 | +
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ #' * `or`: Odds ratio. |
|||
| 438 | -1x | +|||
| 20 | +
- if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) {
+ #' * `ci`: Confidence interval of odds ratio. |
|||
| 439 | -! | +|||
| 21 | +
- ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n+ #' * `pval`: p-value of the effect. |
|||
| 440 | +22 |
- } else {
+ #' Note, the statistics `n_tot`, `or` and `ci` are required. |
||
| 441 | -1x | +|||
| 23 | +
- ci_lwr <- max(0, term1 - term2)+ #' |
|||
| 442 | +24 |
- }+ #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup. |
||
| 443 | -1x | +|||
| 25 | +
- if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) {
+ #' |
|||
| 444 | -! | +|||
| 26 | +
- ci_upr <- 1 - 0.5 * stats::qchisq(+ #' @details These functions create a layout starting from a data frame which contains |
|||
| 445 | -! | +|||
| 27 | +
- alpha,+ #' the required statistics. The tables are then typically used as input for forest plots. |
|||
| 446 | -! | +|||
| 28 | +
- 2 * (n - x)+ #' |
|||
| 447 | -! | +|||
| 29 | +
- ) / n+ #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does |
|||
| 448 | +30 |
- } else {
+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 449 | -1x | +|||
| 31 | +
- ci_upr <- min(1, term1 + term2)+ #' created by combining multiple subtables. |
|||
| 450 | +32 |
- }+ #' |
||
| 451 | +33 |
- },+ #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()]. |
||
| 452 | -26x | +|||
| 34 | +
- `modified jeffreys` = {
+ #' |
|||
| 453 | -1x | +|||
| 35 | +
- if (x == n) {
+ #' @examples |
|||
| 454 | -! | +|||
| 36 | +
- ci_lwr <- (alpha / 2)^(1 / n)+ #' library(dplyr) |
|||
| 455 | +37 |
- } else {
+ #' library(forcats) |
||
| 456 | -1x | +|||
| 38 | +
- if (x <= 1) {
+ #' |
|||
| 457 | -! | +|||
| 39 | +
- ci_lwr <- 0+ #' adrs <- tern_ex_adrs |
|||
| 458 | +40 |
- } else {
+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 459 | -1x | +|||
| 41 | +
- ci_lwr <- stats::qbeta(+ #' |
|||
| 460 | -1x | +|||
| 42 | +
- alpha / 2,+ #' adrs_f <- adrs %>% |
|||
| 461 | -1x | +|||
| 43 | +
- x + 0.5, n - x + 0.5+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 462 | +44 |
- )+ #' mutate(rsp = AVALC == "CR") |
||
| 463 | +45 |
- }+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 464 | +46 |
- }+ #' |
||
| 465 | -1x | +|||
| 47 | +
- if (x == 0) {
+ #' df <- extract_rsp_biomarkers( |
|||
| 466 | -! | +|||
| 48 | +
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ #' variables = list( |
|||
| 467 | +49 |
- } else {
+ #' rsp = "rsp", |
||
| 468 | -1x | +|||
| 50 | +
- if (x >= n - 1) {
+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 469 | -! | +|||
| 51 | +
- ci_upr <- 1+ #' covariates = "SEX", |
|||
| 470 | +52 |
- } else {
+ #' subgroups = "BMRKR2" |
||
| 471 | -1x | +|||
| 53 | +
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)+ #' ), |
|||
| 472 | +54 |
- }+ #' data = adrs_f |
||
| 473 | +55 |
- }+ #' ) |
||
| 474 | +56 |
- },+ #' |
||
| 475 | -26x | +|||
| 57 | +
- `clopper-pearson` = {
+ #' \donttest{
|
|||
| 476 | -1x | +|||
| 58 | +
- ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1)+ #' ## Table with default columns. |
|||
| 477 | -1x | +|||
| 59 | +
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x)+ #' tabulate_rsp_biomarkers(df) |
|||
| 478 | +60 |
- },+ #' |
||
| 479 | -26x | +|||
| 61 | +
- arcsine = {
+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
|||
| 480 | -1x | +|||
| 62 | +
- p_tilde <- (x + 0.375) / (n + 0.75)+ #' tab <- tabulate_rsp_biomarkers( |
|||
| 481 | -1x | +|||
| 63 | +
- est <- p_tilde+ #' df = df, |
|||
| 482 | -1x | +|||
| 64 | +
- ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2+ #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
|
|||
| 483 | -1x | +|||
| 65 | +
- ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2+ #' ) |
|||
| 484 | +66 |
- },+ #' |
||
| 485 | -26x | +|||
| 67 | +
- logit = {
+ #' ## Finally produce the forest plot. |
|||
| 486 | -1x | +|||
| 68 | +
- lambda_hat <- log(x / (n - x))+ #' g_forest(tab, xlim = c(0.7, 1.4)) |
|||
| 487 | -1x | +|||
| 69 | +
- V_hat <- n / (x * (n - x)) # nolint+ #' } |
|||
| 488 | -1x | +|||
| 70 | +
- lambda_lower <- lambda_hat - kappa * sqrt(V_hat)+ #' |
|||
| 489 | -1x | +|||
| 71 | +
- lambda_upper <- lambda_hat + kappa * sqrt(V_hat)+ #' @export |
|||
| 490 | -1x | +|||
| 72 | +
- ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower))+ #' @name response_biomarkers_subgroups |
|||
| 491 | -1x | +|||
| 73 | +
- ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper))+ tabulate_rsp_biomarkers <- function(df, |
|||
| 492 | +74 |
- },+ vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
||
| 493 | -26x | +|||
| 75 | +
- witting = {
+ na_str = default_na_str(), |
|||
| 494 | -1x | +|||
| 76 | +
- set.seed(rand)+ .indent_mods = 0L) {
|
|||
| 495 | -1x | +77 | +4x |
- x_tilde <- x + stats::runif(1, min = 0, max = 1)+ checkmate::assert_data_frame(df) |
| 496 | -1x | +78 | +4x |
- pbinom_abscont <- function(q, size, prob) {
+ checkmate::assert_character(df$biomarker) |
| 497 | -22x | +79 | +4x |
- v <- trunc(q)+ checkmate::assert_character(df$biomarker_label) |
| 498 | -22x | +80 | +4x |
- term1 <- stats::pbinom(v - 1, size = size, prob = prob)+ checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
|
| 499 | -22x | +|||
| 81 | +
- term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob)+ + |
+ |||
| 82 | ++ |
+ # Create "ci" column from "lcl" and "ucl" |
||
| 500 | -22x | +83 | +4x |
- return(term1 + term2)+ df$ci <- combine_vectors(df$lcl, df$ucl) |
| 501 | +84 |
- }+ |
||
| 502 | -1x | +85 | +4x |
- qbinom_abscont <- function(p, size, x) {
+ df_subs <- split(df, f = df$biomarker) |
| 503 | -2x | +86 | +4x |
- fun <- function(prob, size, x, p) {
+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
| 504 | -22x | +87 | +7x |
- pbinom_abscont(x, size, prob) - p+ tab_sub <- h_tab_rsp_one_biomarker( |
| 505 | -+ | |||
| 88 | +7x |
- }+ df = df_sub, |
||
| 506 | -2x | +89 | +7x |
- stats::uniroot(fun,+ vars = vars, |
| 507 | -2x | +90 | +7x |
- interval = c(0, 1), size = size,+ na_str = na_str, |
| 508 | -2x | +91 | +7x |
- x = x, p = p+ .indent_mods = .indent_mods |
| 509 | -2x | +|||
| 92 | +
- )$root+ ) |
|||
| 510 | +93 |
- }+ # Insert label row as first row in table. |
||
| 511 | -1x | +94 | +7x |
- ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde)+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
| 512 | -1x | +95 | +7x |
- ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde)+ tab_sub |
| 513 | +96 |
- },+ }) |
||
| 514 | -26x | +97 | +4x |
- pratt = {
+ result <- do.call(rbind, tabs) |
| 515 | -1x | +|||
| 98 | +
- if (x == 0) {
+
|
|||
| 516 | -! | +|||
| 99 | +4x |
- ci_lwr <- 0+ n_id <- grep("n_tot", vars)
|
||
| 517 | -! | +|||
| 100 | +4x |
- ci_upr <- 1 - alpha^(1 / n)+ or_id <- match("or", vars)
|
||
| 518 | -1x | +101 | +4x |
- } else if (x == 1) {
+ ci_id <- match("ci", vars)
|
| 519 | -! | +|||
| 102 | +4x |
- ci_lwr <- 1 - (1 - alpha / 2)^(1 / n)+ structure( |
||
| 520 | -! | +|||
| 103 | +4x |
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ result, |
||
| 521 | -1x | +104 | +4x |
- } else if (x == (n - 1)) {
+ forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
|
| 522 | -! | +|||
| 105 | +4x |
- ci_lwr <- (alpha / 2)^(1 / n)+ col_x = or_id, |
||
| 523 | -! | +|||
| 106 | +4x |
- ci_upr <- (1 - alpha / 2)^(1 / n)+ col_ci = ci_id, |
||
| 524 | -1x | +107 | +4x |
- } else if (x == n) {
+ col_symbol_size = n_id |
| 525 | -! | +|||
| 108 | +
- ci_lwr <- alpha^(1 / n)+ ) |
|||
| 526 | -! | +|||
| 109 | +
- ci_upr <- 1+ } |
|||
| 527 | +110 |
- } else {
+
|
||
| 528 | -1x | +|||
| 111 | +
- z <- stats::qnorm(1 - alpha / 2)+ #' Prepare response data estimates for multiple biomarkers in a single data frame |
|||
| 529 | -1x | +|||
| 112 | +
- A <- ((x + 1) / (n - x))^2 # nolint+ #' |
|||
| 530 | -1x | +|||
| 113 | +
- B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint+ #' @description `r lifecycle::badge("stable")`
|
|||
| 531 | -1x | +|||
| 114 | +
- C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint+ #' |
|||
| 532 | -1x | +|||
| 115 | +
- D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint+ #' Prepares estimates for number of responses, patients and overall response rate, |
|||
| 533 | -1x | +|||
| 116 | +
- E <- 1 + A * ((B + C) / D)^3 # nolint+ #' as well as odds ratio estimates, confidence intervals and p-values, |
|||
| 534 | -1x | +|||
| 117 | +
- ci_upr <- 1 / E+ #' for multiple biomarkers across population subgroups in a single data frame. |
|||
| 535 | -1x | +|||
| 118 | +
- A <- (x / (n - x - 1))^2 # nolint+ #' `variables` corresponds to the names of variables found in `data`, passed as a |
|||
| 536 | -1x | +|||
| 119 | +
- B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint+ #' named list and requires elements `rsp` and `biomarkers` (vector of continuous |
|||
| 537 | -1x | +|||
| 120 | +
- C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint+ #' biomarker variables) and optionally `covariates`, `subgroups` and `strata`. |
|||
| 538 | -1x | +|||
| 121 | +
- D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|||
| 539 | -1x | +|||
| 122 | +
- E <- 1 + A * ((B + C) / D)^3 # nolint+ #' |
|||
| 540 | -1x | +|||
| 123 | +
- ci_lwr <- 1 / E+ #' @inheritParams argument_convention |
|||
| 541 | +124 |
- }+ #' @inheritParams response_subgroups |
||
| 542 | +125 |
- },+ #' @param control (named `list`)\cr controls for the response definition and the |
||
| 543 | -26x | +|||
| 126 | +
- midp = {
+ #' confidence level produced by [control_logistic()]. |
|||
| 544 | -1x | +|||
| 127 | +
- f_low <- function(pi, x, n) {
+ #' |
|||
| 545 | -12x | +|||
| 128 | +
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x,+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`, |
|||
| 546 | -12x | +|||
| 129 | +
- size = n, prob = pi, lower.tail = FALSE+ #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
|||
| 547 | +130 |
- ) -+ #' `var_label`, and `row_type`. |
||
| 548 | -12x | +|||
| 131 | +
- (1 - conf.level) / 2+ #' |
|||
| 549 | +132 |
- }+ #' @note You can also specify a continuous variable in `rsp` and then use the |
||
| 550 | -1x | +|||
| 133 | +
- f_up <- function(pi, x, n) {
+ #' `response_definition` control to convert that internally to a logical |
|||
| 551 | -12x | +|||
| 134 | +
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2+ #' variable reflecting binary response. |
|||
| 552 | +135 |
- }+ #' |
||
| 553 | -1x | +|||
| 136 | +
- ci_lwr <- 0+ #' @seealso [h_logistic_mult_cont_df()] which is used internally. |
|||
| 554 | -1x | +|||
| 137 | +
- ci_upr <- 1+ #' |
|||
| 555 | -1x | +|||
| 138 | +
- if (x != 0) {
+ #' @examples |
|||
| 556 | -1x | +|||
| 139 | +
- ci_lwr <- stats::uniroot(f_low,+ #' library(dplyr) |
|||
| 557 | -1x | +|||
| 140 | +
- interval = c(0, p_hat),+ #' library(forcats) |
|||
| 558 | -1x | +|||
| 141 | +
- x = x, n = n+ #' |
|||
| 559 | -1x | +|||
| 142 | +
- )$root+ #' adrs <- tern_ex_adrs |
|||
| 560 | +143 |
- }+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 561 | -1x | +|||
| 144 | +
- if (x != n) {
+ #' |
|||
| 562 | -1x | +|||
| 145 | +
- ci_upr <- stats::uniroot(f_up, interval = c(+ #' adrs_f <- adrs %>% |
|||
| 563 | -1x | +|||
| 146 | +
- p_hat,+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 564 | -1x | +|||
| 147 | +
- 1+ #' mutate(rsp = AVALC == "CR") |
|||
| 565 | -1x | +|||
| 148 | +
- ), x = x, n = n)$root+ #' |
|||
| 566 | +149 |
- }+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
||
| 567 | +150 |
- },+ #' # in logistic regression models with one covariate `RACE`. The subgroups |
||
| 568 | -26x | +|||
| 151 | +
- lik = {
+ #' # are defined by the levels of `BMRKR2`. |
|||
| 569 | -2x | +|||
| 152 | +
- ci_lwr <- 0+ #' df <- extract_rsp_biomarkers( |
|||
| 570 | -2x | +|||
| 153 | +
- ci_upr <- 1+ #' variables = list( |
|||
| 571 | -2x | +|||
| 154 | +
- z <- stats::qnorm(1 - alpha * 0.5)+ #' rsp = "rsp", |
|||
| 572 | -2x | +|||
| 155 | +
- tol <- .Machine$double.eps^0.5+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 573 | -2x | +|||
| 156 | +
- BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint+ #' covariates = "SEX", |
|||
| 574 | +157 |
- ...) {
+ #' subgroups = "BMRKR2" |
||
| 575 | -40x | +|||
| 158 | +
- ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt,+ #' ), |
|||
| 576 | -40x | +|||
| 159 | +
- y,+ #' data = adrs_f |
|||
| 577 | -40x | +|||
| 160 | +
- log = TRUE+ #' ) |
|||
| 578 | +161 |
- ))+ #' df |
||
| 579 | -40x | +|||
| 162 | +
- ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x,+ #' |
|||
| 580 | -40x | +|||
| 163 | +
- wt, mu,+ #' # Here we group the levels of `BMRKR2` manually, and we add a stratification |
|||
| 581 | -40x | +|||
| 164 | +
- log = TRUE+ #' # variable `STRATA1`. We also here use a continuous variable `EOSDY` |
|||
| 582 | +165 |
- ))+ #' # which is then binarized internally (response is defined as this variable |
||
| 583 | -40x | +|||
| 166 | +
- res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu)))+ #' # being larger than 750). |
|||
| 584 | -40x | +|||
| 167 | +
- return(res - bound)+ #' df_grouped <- extract_rsp_biomarkers( |
|||
| 585 | +168 |
- }+ #' variables = list( |
||
| 586 | -2x | +|||
| 169 | +
- if (x != 0 && tol < p_hat) {
+ #' rsp = "EOSDY", |
|||
| 587 | -2x | +|||
| 170 | +
- ci_lwr <- if (BinDev(+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 588 | -2x | +|||
| 171 | +
- tol, x, p_hat, n, -z,+ #' covariates = "SEX", |
|||
| 589 | -2x | +|||
| 172 | +
- tol+ #' subgroups = "BMRKR2", |
|||
| 590 | -2x | +|||
| 173 | +
- ) <= 0) {
+ #' strata = "STRATA1" |
|||
| 591 | -2x | +|||
| 174 | +
- stats::uniroot(+ #' ), |
|||
| 592 | -2x | +|||
| 175 | +
- f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) {
+ #' data = adrs_f, |
|||
| 593 | -! | +|||
| 176 | +
- 1 - tol+ #' groups_lists = list( |
|||
| 594 | +177 |
- } else {
+ #' BMRKR2 = list( |
||
| 595 | -2x | +|||
| 178 | +
- p_hat+ #' "low" = "LOW", |
|||
| 596 | -2x | +|||
| 179 | +
- }), bound = -z,+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 597 | -2x | +|||
| 180 | +
- x = x, mu = p_hat, wt = n+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|||
| 598 | -2x | +|||
| 181 | +
- )$root+ #' ) |
|||
| 599 | +182 |
- }+ #' ), |
||
| 600 | +183 |
- }+ #' control = control_logistic( |
||
| 601 | -2x | +|||
| 184 | +
- if (x != n && p_hat < (1 - tol)) {
+ #' response_definition = "I(response > 750)" |
|||
| 602 | -2x | +|||
| 185 | +
- ci_upr <- if (+ #' ) |
|||
| 603 | -2x | +|||
| 186 | +
- BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat > 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) < 0) { # nolint
+ #' ) |
|||
| 604 | -! | +|||
| 187 | +
- ci_lwr <- if (BinDev(+ #' df_grouped |
|||
| 605 | -! | +|||
| 188 | +
- tol, x, if (p_hat < tol || p_hat == 1) {
+ #' |
|||
| 606 | -! | +|||
| 189 | +
- 1 - tol+ #' @export |
|||
| 607 | +190 |
- } else {
+ extract_rsp_biomarkers <- function(variables, |
||
| 608 | -! | +|||
| 191 | +
- p_hat+ data, |
|||
| 609 | -! | +|||
| 192 | +
- }, n,+ groups_lists = list(), |
|||
| 610 | -! | +|||
| 193 | +
- -z, tol+ control = control_logistic(), |
|||
| 611 | -! | +|||
| 194 | +
- ) <= 0) {
+ label_all = "All Patients") {
|
|||
| 612 | -! | +|||
| 195 | +5x |
- stats::uniroot(+ if ("strat" %in% names(variables)) {
|
||
| 613 | +196 | ! |
- f = BinDev, interval = c(tol, p_hat),+ warning( |
|
| 614 | +197 | ! |
- bound = -z, x = x, mu = p_hat, wt = n+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_biomarkers() ", |
|
| 615 | +198 | ! |
- )$root+ "was deprecated in tern 0.9.4.\n ", |
|
| 616 | -+ | |||
| 199 | +! |
- }+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 617 | +200 |
- } else {
- |
- ||
| 618 | -2x | -
- stats::uniroot(- |
- ||
| 619 | -2x | -
- f = BinDev, interval = c(if (p_hat > 1 - tol) {
+ ) |
||
| 620 | +201 | ! |
- tol+ variables[["strata"]] <- variables[["strat"]] |
|
| 621 | +202 |
- } else {
+ } |
||
| 622 | -2x | +|||
| 203 | +
- p_hat+ |
|||
| 623 | -2x | +204 | +5x |
- }, 1 - tol), bound = z,+ assert_list_of_variables(variables) |
| 624 | -2x | +205 | +5x |
- x = x, mu = p_hat, wt = n+ checkmate::assert_string(variables$rsp) |
| 625 | -2x | +206 | +5x |
- )$root+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 626 | -+ | |||
| 207 | +5x |
- }+ checkmate::assert_string(label_all) |
||
| 627 | +208 |
- }+ |
||
| 628 | +209 |
- },+ # Start with all patients. |
||
| 629 | -26x | +210 | +5x |
- blaker = {
+ result_all <- h_logistic_mult_cont_df( |
| 630 | -1x | +211 | +5x |
- acceptbin <- function(x, n, p) {
+ variables = variables, |
| 631 | -3954x | +212 | +5x |
- p1 <- 1 - stats::pbinom(x - 1, n, p)+ data = data, |
| 632 | -3954x | +213 | +5x |
- p2 <- stats::pbinom(x, n, p)+ control = control |
| 633 | -3954x | +|||
| 214 | +
- a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p)+ ) |
|||
| 634 | -3954x | +215 | +5x |
- a2 <- p2 + 1 - stats::pbinom(+ result_all$subgroup <- label_all |
| 635 | -3954x | +216 | +5x |
- stats::qbinom(1 - p2, n, p), n,+ result_all$var <- "ALL" |
| 636 | -3954x | +217 | +5x |
- p+ result_all$var_label <- label_all |
| 637 | -+ | |||
| 218 | +5x |
- )+ result_all$row_type <- "content" |
||
| 638 | -3954x | +219 | +5x |
- return(min(a1, a2))+ if (is.null(variables$subgroups)) {
|
| 639 | +220 |
- }+ # Only return result for all patients. |
||
| 640 | +221 | 1x |
- ci_lwr <- 0+ result_all |
|
| 641 | -1x | +|||
| 222 | +
- ci_upr <- 1+ } else {
|
|||
| 642 | -1x | +|||
| 223 | +
- if (x != 0) {
+ # Add subgroups results. |
|||
| 643 | -1x | +224 | +4x |
- ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1)+ l_data <- h_split_by_subgroups( |
| 644 | -1x | +225 | +4x |
- while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) {
+ data, |
| 645 | -1976x | +226 | +4x |
- ci_lwr <- ci_lwr + tol+ variables$subgroups, |
| 646 | -+ | |||
| 227 | +4x |
- }+ groups_lists = groups_lists |
||
| 647 | +228 |
- }+ ) |
||
| 648 | -1x | +229 | +4x |
- if (x != n) {
+ l_result <- lapply(l_data, function(grp) {
|
| 649 | -1x | +230 | +20x |
- ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x)+ result <- h_logistic_mult_cont_df( |
| 650 | -1x | +231 | +20x |
- while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) {
+ variables = variables, |
| 651 | -1976x | +232 | +20x |
- ci_upr <- ci_upr - tol+ data = grp$df, |
| 652 | -+ | |||
| 233 | +20x |
- }+ control = control |
||
| 653 | +234 |
- }- |
- ||
| 654 | -- |
- }- |
- ||
| 655 | -- |
- )- |
- ||
| 656 | -26x | -
- ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min(- |
- ||
| 657 | -26x | -
- 1,- |
- ||
| 658 | -26x | -
- ci_upr- |
- ||
| 659 | -- |
- ))- |
- ||
| 660 | -26x | -
- if (sides == "left") {
- |
- ||
| 661 | -1x | -
- ci[3] <- 1- |
- ||
| 662 | -25x | -
- } else if (sides == "right") {
- |
- ||
| 663 | -! | -
- ci[2] <- 0- |
- ||
| 664 | -- |
- }- |
- ||
| 665 | -26x | -
- return(ci)- |
- ||
| 666 | -- |
- }- |
- ||
| 667 | -26x | -
- lst <- list(- |
- ||
| 668 | -26x | -
- x = x, n = n, conf.level = conf.level, sides = sides,- |
- ||
| 669 | -26x | -
- method = method, rand = rand- |
- ||
| 670 | -- |
- )- |
- ||
| 671 | -26x | -
- maxdim <- max(unlist(lapply(lst, length)))- |
- ||
| 672 | -26x | -
- lgp <- lapply(lst, rep, length.out = maxdim)- |
- ||
| 673 | -26x | -
- lgn <- h_recycle(x = if (is.null(names(x))) {
- |
- ||
| 674 | -26x | -
- paste("x", seq_along(x), sep = ".")
- |
- ||
| 675 | -- |
- } else {
- |
- ||
| 676 | -! | -
- names(x)+ ) |
||
| 677 | -26x | +235 | +20x |
- }, n = if (is.null(names(n))) {
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 678 | -26x | +236 | +20x |
- paste("n", seq_along(n), sep = ".")
+ cbind(result, result_labels) |
| 679 | +237 |
- } else {
- |
- ||
| 680 | -! | -
- names(n)- |
- ||
| 681 | -26x | -
- }, conf.level = conf.level, sides = sides, method = method)- |
- ||
| 682 | -26x | -
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
- |
- ||
| 683 | -130x | -
- length(unique(x)) !=- |
- ||
| 684 | -130x | -
- 1- |
- ||
| 685 | -26x | -
- })]), 1, paste, collapse = ":")+ }) |
||
| 686 | -26x | +238 | +4x |
- res <- t(sapply(1:maxdim, function(i) {
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 687 | -26x | +239 | +4x |
- iBinomCI(+ result_subgroups$row_type <- "analysis" |
| 688 | -26x | +240 | +4x |
- x = lgp$x[i],+ rbind( |
| 689 | -26x | +241 | +4x |
- n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i],+ result_all, |
| 690 | -26x | +242 | +4x |
- method = lgp$method[i], rand = lgp$rand[i]+ result_subgroups |
| 691 | +243 |
) |
||
| 692 | +244 |
- }))- |
- ||
| 693 | -26x | -
- colnames(res)[1] <- c("est")
- |
- ||
| 694 | -26x | -
- rownames(res) <- xn- |
- ||
| 695 | -26x | -
- return(res)+ } |
||
| 696 | +245 |
}@@ -77991,14 +74828,14 @@ tern coverage - 95.65% |
| 1 |
- #' Subgroup treatment effect pattern (STEP) fit for survival outcome+ #' Tabulate biomarker effects on survival by subgroup |
||
| 5 |
- #' This fits the subgroup treatment effect pattern (STEP) models for a survival outcome. The treatment arm+ #' The [tabulate_survival_biomarkers()] function creates a layout element to tabulate the estimated effects of multiple |
||
| 6 |
- #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated+ #' continuous biomarker variables on survival across subgroups, returning statistics including median survival time and |
||
| 7 |
- #' hazard ratios are for the comparison of the second level vs. the first one.+ #' hazard ratio for each population subgroup. The table is created from `df`, a list of data frames returned by |
||
| 8 |
- #'+ #' [extract_survival_biomarkers()], with the statistics to include specified via the `vars` parameter. |
||
| 9 |
- #' The model which is fit is:+ #' |
||
| 10 |
- #'+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 11 |
- #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ #' |
||
| 12 |
- #'+ #' @inheritParams fit_coxreg_multivar |
||
| 13 |
- #' where `degree` is specified by `control_step()`.+ #' @inheritParams survival_duration_subgroups |
||
| 14 |
- #'+ #' @inheritParams argument_convention |
||
| 15 |
- #' @inheritParams argument_convention+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
||
| 16 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`,+ #' [extract_survival_biomarkers()]. |
||
| 17 |
- #' `arm`, `biomarker`, and optional `covariates` and `strata`.+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 18 |
- #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].+ #' * `n_tot_events`: Total number of events per group. |
||
| 19 |
- #'+ #' * `n_tot`: Total number of observations per group. |
||
| 20 |
- #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used+ #' * `median`: Median survival time. |
||
| 21 |
- #' for the biomarker variable, including where the center of the intervals are and their bounds. The+ #' * `hr`: Hazard ratio. |
||
| 22 |
- #' second part of the columns contain the estimates for the treatment arm comparison.+ #' * `ci`: Confidence interval of hazard ratio. |
||
| 23 |
- #'+ #' * `pval`: p-value of the effect. |
||
| 24 |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required. |
||
| 26 |
- #' @seealso [control_step()] and [control_coxph()] for the available customization options.+ #' @details These functions create a layout starting from a data frame which contains |
||
| 27 |
- #'+ #' the required statistics. The tables are then typically used as input for forest plots. |
||
| 28 |
- #' @examples+ #' |
||
| 29 |
- #' # Testing dataset with just two treatment arms.+ #' @examples |
||
| 32 |
- #' adtte_f <- tern_ex_adtte %>%+ #' adtte <- tern_ex_adtte |
||
| 33 |
- #' filter(+ #' |
||
| 34 |
- #' PARAMCD == "OS",+ #' # Save variable labels before data processing steps. |
||
| 35 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 36 |
- #' ) %>%+ #' |
||
| 37 |
- #' mutate(+ #' adtte_f <- adtte %>% |
||
| 38 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' filter(PARAMCD == "OS") %>% |
||
| 39 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ #' mutate( |
||
| 40 |
- #' is_event = CNSR == 0+ #' AVALU = as.character(AVALU), |
||
| 41 |
- #' )+ #' is_event = CNSR == 0 |
||
| 42 |
- #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
+ #' ) |
||
| 43 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
||
| 44 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 45 |
- #' variables <- list(+ #' |
||
| 46 |
- #' arm = "ARM",+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
||
| 47 |
- #' biomarker = "BMRKR1",+ #' # in multiple regression models containing one covariate `RACE`, |
||
| 48 |
- #' covariates = c("AGE", "BMRKR2"),
+ #' # as well as one stratification variable `STRATA1`. The subgroups |
||
| 49 |
- #' event = "is_event",+ #' # are defined by the levels of `BMRKR2`. |
||
| 50 |
- #' time = "AVAL"+ #' |
||
| 51 |
- #' )+ #' df <- extract_survival_biomarkers( |
||
| 52 |
- #'+ #' variables = list( |
||
| 53 |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ #' tte = "AVAL", |
||
| 54 |
- #' step_matrix <- fit_survival_step(+ #' is_event = "is_event", |
||
| 55 |
- #' variables = variables,+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 56 |
- #' data = adtte_f+ #' strata = "STRATA1", |
||
| 57 |
- #' )+ #' covariates = "SEX", |
||
| 58 |
- #' dim(step_matrix)+ #' subgroups = "BMRKR2" |
||
| 59 |
- #' head(step_matrix)+ #' ), |
||
| 60 |
- #'+ #' label_all = "Total Patients", |
||
| 61 |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ #' data = adtte_f |
||
| 62 |
- #' # models. Or specify different Cox regression options.+ #' ) |
||
| 63 |
- #' step_matrix2 <- fit_survival_step(+ #' df |
||
| 64 |
- #' variables = variables,+ #' |
||
| 65 |
- #' data = adtte_f,+ #' # Here we group the levels of `BMRKR2` manually. |
||
| 66 |
- #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))+ #' df_grouped <- extract_survival_biomarkers( |
||
| 67 |
- #' )+ #' variables = list( |
||
| 68 |
- #'+ #' tte = "AVAL", |
||
| 69 |
- #' # Use a global model with cubic interaction and only 5 points.+ #' is_event = "is_event", |
||
| 70 |
- #' step_matrix3 <- fit_survival_step(+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 71 |
- #' variables = variables,+ #' strata = "STRATA1", |
||
| 72 |
- #' data = adtte_f,+ #' covariates = "SEX", |
||
| 73 |
- #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))+ #' subgroups = "BMRKR2" |
||
| 74 |
- #' )+ #' ), |
||
| 75 |
- #'+ #' data = adtte_f, |
||
| 76 |
- #' @export+ #' groups_lists = list( |
||
| 77 |
- fit_survival_step <- function(variables,+ #' BMRKR2 = list( |
||
| 78 |
- data,+ #' "low" = "LOW", |
||
| 79 |
- control = c(control_step(), control_coxph())) {
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 80 | -4x | +
- checkmate::assert_list(control)+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|
| 81 | -4x | +
- assert_df_with_variables(data, variables)+ #' ) |
|
| 82 | -4x | +
- data <- data[!is.na(data[[variables$biomarker]]), ]+ #' ) |
|
| 83 | -4x | +
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ #' ) |
|
| 84 | -4x | +
- interval_center <- window_sel$interval[, "Interval Center"]+ #' df_grouped |
|
| 85 | -4x | +
- form <- h_step_survival_formula(variables = variables, control = control)+ #' |
|
| 86 | -4x | +
- estimates <- if (is.null(control$bandwidth)) {
+ #' @name survival_biomarkers_subgroups |
|
| 87 | -1x | +
- h_step_survival_est(+ #' @order 1 |
|
| 88 | -1x | +
- formula = form,+ NULL |
|
| 89 | -1x | +
- data = data,+ |
|
| 90 | -1x | +
- variables = variables,+ #' Prepare survival data estimates for multiple biomarkers in a single data frame |
|
| 91 | -1x | +
- x = interval_center,+ #' |
|
| 92 | -1x | +
- control = control+ #' @description `r lifecycle::badge("stable")`
|
|
| 93 |
- )+ #' |
||
| 94 |
- } else {
+ #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates, |
||
| 95 | -3x | +
- tmp <- mapply(+ #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame. |
|
| 96 | -3x | +
- FUN = h_step_survival_est,+ #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements |
|
| 97 | -3x | +
- x = interval_center,+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strata`. |
|
| 98 | -3x | +
- subset = as.list(as.data.frame(window_sel$sel)),+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|
| 99 | -3x | +
- MoreArgs = list(+ #' |
|
| 100 | -3x | +
- formula = form,+ #' @inheritParams argument_convention |
|
| 101 | -3x | +
- data = data,+ #' @inheritParams fit_coxreg_multivar |
|
| 102 | -3x | +
- variables = variables,+ #' @inheritParams survival_duration_subgroups |
|
| 103 | -3x | +
- control = control+ #' |
|
| 104 |
- )+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`, |
||
| 105 |
- )+ #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
||
| 106 |
- # Maybe we find a more elegant solution than this.+ #' `var_label`, and `row_type`. |
||
| 107 | -3x | +
- rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
+ #' |
|
| 108 | -3x | +
- t(tmp)+ #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()]. |
|
| 109 |
- }+ #' |
||
| 110 | -4x | +
- result <- cbind(window_sel$interval, estimates)+ #' @export |
|
| 111 | -4x | +
- structure(+ extract_survival_biomarkers <- function(variables, |
|
| 112 | -4x | +
- result,+ data, |
|
| 113 | -4x | +
- class = c("step", "matrix"),
+ groups_lists = list(), |
|
| 114 | -4x | +
- variables = variables,+ control = control_coxreg(), |
|
| 115 | -4x | +
- control = control+ label_all = "All Patients") {
|
|
| 116 | -+ | 6x |
- )+ if ("strat" %in% names(variables)) {
|
| 117 | -+ | ! |
- }+ warning( |
| 1 | -+ | |||
| 118 | +! |
- #' Tabulate binary response by subgroup+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_biomarkers() ", |
||
| 2 | -+ | |||
| 119 | +! |
- #'+ "was deprecated in tern 0.9.4.\n ", |
||
| 3 | -+ | |||
| 120 | +! |
- #' @description `r lifecycle::badge("stable")`
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 4 | +121 |
- #'+ ) |
||
| 5 | -+ | |||
| 122 | +! |
- #' The [tabulate_rsp_subgroups()] function creates a layout element to tabulate binary response by subgroup, returning+ variables[["strata"]] <- variables[["strat"]] |
||
| 6 | +123 |
- #' statistics including response rate and odds ratio for each population subgroup. The table is created from `df`, a+ } |
||
| 7 | +124 |
- #' list of data frames returned by [extract_rsp_subgroups()], with the statistics to include specified via the `vars`+ |
||
| 8 | -+ | |||
| 125 | +6x |
- #' parameter.+ checkmate::assert_list(variables) |
||
| 9 | -+ | |||
| 126 | +6x |
- #'+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 10 | -+ | |||
| 127 | +6x |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ checkmate::assert_string(label_all) |
||
| 11 | +128 |
- #'+ |
||
| 12 | +129 |
- #' @inheritParams extract_rsp_subgroups+ # Start with all patients. |
||
| 13 | -+ | |||
| 130 | +6x |
- #' @inheritParams argument_convention+ result_all <- h_coxreg_mult_cont_df( |
||
| 14 | -+ | |||
| 131 | +6x |
- #'+ variables = variables, |
||
| 15 | -+ | |||
| 132 | +6x |
- #' @details These functions create a layout starting from a data frame which contains+ data = data, |
||
| 16 | -+ | |||
| 133 | +6x |
- #' the required statistics. Tables typically used as part of forest plot.+ control = control |
||
| 17 | +134 |
- #'+ ) |
||
| 18 | -+ | |||
| 135 | +6x |
- #' @seealso [extract_rsp_subgroups()]+ result_all$subgroup <- label_all |
||
| 19 | -+ | |||
| 136 | +6x |
- #'+ result_all$var <- "ALL" |
||
| 20 | -+ | |||
| 137 | +6x |
- #' @examples+ result_all$var_label <- label_all |
||
| 21 | -+ | |||
| 138 | +6x |
- #' library(dplyr)+ result_all$row_type <- "content" |
||
| 22 | -+ | |||
| 139 | +6x |
- #' library(forcats)+ if (is.null(variables$subgroups)) {
|
||
| 23 | +140 |
- #'+ # Only return result for all patients. |
||
| 24 | -+ | |||
| 141 | +1x |
- #' adrs <- tern_ex_adrs+ result_all |
||
| 25 | +142 |
- #' adrs_labels <- formatters::var_labels(adrs)+ } else {
|
||
| 26 | +143 |
- #'+ # Add subgroups results. |
||
| 27 | -+ | |||
| 144 | +5x |
- #' adrs_f <- adrs %>%+ l_data <- h_split_by_subgroups( |
||
| 28 | -+ | |||
| 145 | +5x |
- #' filter(PARAMCD == "BESRSPI") %>%+ data, |
||
| 29 | -+ | |||
| 146 | +5x |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ variables$subgroups, |
||
| 30 | -+ | |||
| 147 | +5x |
- #' droplevels() %>%+ groups_lists = groups_lists |
||
| 31 | +148 |
- #' mutate(+ ) |
||
| 32 | -+ | |||
| 149 | +5x |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ l_result <- lapply(l_data, function(grp) {
|
||
| 33 | -+ | |||
| 150 | +25x |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ result <- h_coxreg_mult_cont_df( |
||
| 34 | -+ | |||
| 151 | +25x |
- #' rsp = AVALC == "CR"+ variables = variables, |
||
| 35 | -+ | |||
| 152 | +25x |
- #' )+ data = grp$df, |
||
| 36 | -+ | |||
| 153 | +25x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ control = control |
||
| 37 | +154 |
- #'+ ) |
||
| 38 | -+ | |||
| 155 | +25x |
- #' # Unstratified analysis.+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
||
| 39 | -+ | |||
| 156 | +25x |
- #' df <- extract_rsp_subgroups(+ cbind(result, result_labels) |
||
| 40 | +157 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ }) |
||
| 41 | -+ | |||
| 158 | +5x |
- #' data = adrs_f+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 42 | -+ | |||
| 159 | +5x |
- #' )+ result_subgroups$row_type <- "analysis" |
||
| 43 | -+ | |||
| 160 | +5x |
- #' df+ rbind( |
||
| 44 | -+ | |||
| 161 | +5x |
- #'+ result_all,+ |
+ ||
| 162 | +5x | +
+ result_subgroups |
||
| 45 | +163 |
- #' # Stratified analysis.+ ) |
||
| 46 | +164 |
- #' df_strat <- extract_rsp_subgroups(+ } |
||
| 47 | +165 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"),
+ } |
||
| 48 | +166 |
- #' data = adrs_f+ |
||
| 49 | +167 |
- #' )+ #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table |
||
| 50 | +168 |
- #' df_strat+ #' summarizing biomarker effects on survival by subgroup. |
||
| 51 | +169 |
#' |
||
| 52 | +170 |
- #' # Grouping of the BMRKR2 levels.+ #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
|
||
| 53 | +171 |
- #' df_grouped <- extract_rsp_subgroups(+ #' [extract_survival_biomarkers()] function when creating `df`. |
||
| 54 | +172 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' |
||
| 55 | +173 |
- #' data = adrs_f,+ #' @return An `rtables` table summarizing biomarker effects on survival by subgroup. |
||
| 56 | +174 |
- #' groups_lists = list(+ #' |
||
| 57 | +175 |
- #' BMRKR2 = list(+ #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does |
||
| 58 | +176 |
- #' "low" = "LOW",+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 59 | +177 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' created by combining multiple subtables. |
||
| 60 | +178 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' |
||
| 61 | +179 |
- #' )+ #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()]. |
||
| 62 | +180 |
- #' )+ #' |
||
| 63 | +181 |
- #' )+ #' @examples |
||
| 64 | +182 |
- #' df_grouped+ #' ## Table with default columns. |
||
| 65 | +183 |
- #'+ #' tabulate_survival_biomarkers(df) |
||
| 66 | +184 |
- #' @name response_subgroups+ #' |
||
| 67 | +185 |
- #' @order 1+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
||
| 68 | +186 |
- NULL+ #' tab <- tabulate_survival_biomarkers( |
||
| 69 | +187 |
-
+ #' df = df, |
||
| 70 | +188 |
- #' Prepare response data for population subgroups in data frames+ #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
|
||
| 71 | +189 |
- #'+ #' time_unit = as.character(adtte_f$AVALU[1]) |
||
| 72 | +190 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 73 | +191 |
#' |
||
| 74 | +192 |
- #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper+ #' ## Finally produce the forest plot. |
||
| 75 | +193 |
- #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two+ #' \donttest{
|
||
| 76 | +194 |
- #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`,+ #' g_forest(tab, xlim = c(0.8, 1.2)) |
||
| 77 | +195 |
- #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`.+ #' } |
||
| 78 | +196 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' |
||
| 79 | +197 |
- #'+ #' @export |
||
| 80 | +198 |
- #' @inheritParams argument_convention+ #' @order 2 |
||
| 81 | +199 |
- #' @inheritParams response_subgroups+ tabulate_survival_biomarkers <- function(df, |
||
| 82 | +200 |
- #' @param label_all (`string`)\cr label for the total population analysis.+ vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 83 | +201 |
- #'+ groups_lists = list(), |
||
| 84 | +202 |
- #' @return A named list of two elements:+ control = control_coxreg(), |
||
| 85 | +203 |
- #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`,+ label_all = lifecycle::deprecated(), |
||
| 86 | +204 |
- #' `var_label`, and `row_type`.+ time_unit = NULL, |
||
| 87 | +205 |
- #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`,+ na_str = default_na_str(), |
||
| 88 | +206 |
- #' `subgroup`, `var`, `var_label`, and `row_type`.+ .indent_mods = 0L) {
|
||
| 89 | -+ | |||
| 207 | +5x |
- #'+ if (lifecycle::is_present(label_all)) {
|
||
| 90 | -+ | |||
| 208 | +1x |
- #' @seealso [response_subgroups]+ lifecycle::deprecate_warn( |
||
| 91 | -+ | |||
| 209 | +1x |
- #'+ "0.9.5", "tabulate_survival_biomarkers(label_all)", |
||
| 92 | -+ | |||
| 210 | +1x |
- #' @export+ details = paste( |
||
| 93 | -+ | |||
| 211 | +1x |
- extract_rsp_subgroups <- function(variables,+ "Please assign the `label_all` parameter within the", |
||
| 94 | -+ | |||
| 212 | +1x |
- data,+ "`extract_survival_biomarkers()` function when creating `df`." |
||
| 95 | +213 |
- groups_lists = list(),+ ) |
||
| 96 | +214 |
- conf_level = 0.95,+ ) |
||
| 97 | +215 |
- method = NULL,+ } |
||
| 98 | +216 |
- label_all = "All Patients") {
+
|
||
| 99 | -14x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 100 | -! | +217 | +5x |
- warning(+ checkmate::assert_data_frame(df) |
| 101 | -! | +|||
| 218 | +5x |
- "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ",+ checkmate::assert_character(df$biomarker) |
||
| 102 | -! | +|||
| 219 | +5x |
- "was deprecated in tern 0.9.4.\n ",+ checkmate::assert_character(df$biomarker_label) |
||
| 103 | -! | +|||
| 220 | +5x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
|
||
| 104 | +221 |
- )- |
- ||
| 105 | -! | -
- variables[["strata"]] <- variables[["strat"]]+ |
||
| 106 | -+ | |||
| 222 | +5x |
- }+ extra_args <- list(groups_lists = groups_lists, control = control) |
||
| 107 | +223 | |||
| 108 | -14x | +224 | +5x |
- df_prop <- h_proportion_subgroups_df(+ df_subs <- split(df, f = df$biomarker) |
| 109 | -14x | +225 | +5x |
- variables,+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
| 110 | -14x | +226 | +9x |
- data,+ tab_sub <- h_tab_surv_one_biomarker( |
| 111 | -14x | +227 | +9x |
- groups_lists = groups_lists,+ df = df_sub, |
| 112 | -14x | +228 | +9x |
- label_all = label_all+ vars = vars, |
| 113 | -+ | |||
| 229 | +9x |
- )+ time_unit = time_unit, |
||
| 114 | -14x | +230 | +9x |
- df_or <- h_odds_ratio_subgroups_df(+ na_str = na_str, |
| 115 | -14x | +231 | +9x |
- variables,+ .indent_mods = .indent_mods, |
| 116 | -14x | +232 | +9x |
- data,+ extra_args = extra_args |
| 117 | -14x | +|||
| 233 | +
- groups_lists = groups_lists,+ ) |
|||
| 118 | -14x | +|||
| 234 | +
- conf_level = conf_level,+ # Insert label row as first row in table. |
|||
| 119 | -14x | +235 | +9x |
- method = method,+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
| 120 | -14x | +236 | +9x |
- label_all = label_all+ tab_sub |
| 121 | +237 |
- )+ })+ |
+ ||
| 238 | +5x | +
+ result <- do.call(rbind, tabs) |
||
| 122 | +239 | |||
| 123 | -14x | +240 | +5x |
- list(prop = df_prop, or = df_or)+ n_tot_ids <- grep("^n_tot", vars)
|
| 124 | -+ | |||
| 241 | +5x |
- }+ hr_id <- match("hr", vars)
|
||
| 125 | -+ | |||
| 242 | +5x |
-
+ ci_id <- match("ci", vars)
|
||
| 126 | -+ | |||
| 243 | +5x |
- #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`.+ structure( |
||
| 127 | -+ | |||
| 244 | +5x |
- #'+ result, |
||
| 128 | -+ | |||
| 245 | +5x |
- #' @return+ forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
|
||
| 129 | -+ | |||
| 246 | +5x |
- #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ col_x = hr_id, |
||
| 130 | -+ | |||
| 247 | +5x |
- #'+ col_ci = ci_id, |
||
| 131 | -+ | |||
| 248 | +5x |
- #' @keywords internal+ col_symbol_size = n_tot_ids[1] |
||
| 132 | +249 |
- a_response_subgroups <- function(.formats = list(+ ) |
||
| 133 | +250 |
- n = "xx", # nolint start+ } |
| 134 | +1 |
- n_rsp = "xx",+ #' Helper function to create a map data frame for `trim_levels_to_map()` |
||
| 135 | +2 |
- prop = "xx.x%",+ #' |
||
| 136 | +3 |
- n_tot = "xx",+ #' @description `r lifecycle::badge("stable")`
|
||
| 137 | +4 |
- or = list(format_extreme_values(2L)),+ #' |
||
| 138 | +5 |
- ci = list(format_extreme_values_ci(2L)),+ #' Helper function to create a map data frame from the input dataset, which can be used as an argument in the |
||
| 139 | +6 |
- pval = "x.xxxx | (<0.0001)",+ #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently. |
||
| 140 | +7 |
- riskdiff = "xx.x (xx.x - xx.x)" # nolint end+ #' |
||
| 141 | +8 |
- ),+ #' @inheritParams argument_convention |
||
| 142 | +9 |
- na_str = default_na_str()) {
- |
- ||
| 143 | -22x | -
- checkmate::assert_list(.formats)- |
- ||
| 144 | -22x | -
- checkmate::assert_subset(- |
- ||
| 145 | -22x | -
- names(.formats),- |
- ||
| 146 | -22x | -
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval", "riskdiff")
+ #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of |
||
| 147 | +10 |
- )+ #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or |
||
| 148 | +11 | - - | -||
| 149 | -22x | -
- afun_lst <- Map(- |
- ||
| 150 | -22x | -
- function(stat, fmt, na_str) {
- |
- ||
| 151 | -157x | -
- function(df, labelstr = "", ...) {
- |
- ||
| 152 | -349x | -
- in_rows(- |
- ||
| 153 | -349x | -
- .list = as.list(df[[stat]]),- |
- ||
| 154 | -349x | -
- .labels = as.character(df$subgroup),- |
- ||
| 155 | -349x | -
- .formats = fmt,- |
- ||
| 156 | -349x | -
- .format_na_strs = na_str+ #' `abnormal = list(Low = "LOW", High = "HIGH"))` |
||
| 157 | +12 |
- )+ #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`. |
||
| 158 | +13 |
- }+ #' |
||
| 159 | +14 |
- },- |
- ||
| 160 | -22x | -
- stat = names(.formats),- |
- ||
| 161 | -22x | -
- fmt = .formats,- |
- ||
| 162 | -22x | -
- na_str = na_str+ #' @return A map `data.frame`. |
||
| 163 | +15 |
- )+ #' |
||
| 164 | +16 |
-
+ #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the |
||
| 165 | -22x | +|||
| 17 | +
- afun_lst+ #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is |
|||
| 166 | +18 |
- }+ #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0 |
||
| 167 | +19 |
-
+ #' for low direction and at least one observation with high range is not missing for high direction. |
||
| 168 | +20 |
- #' @describeIn response_subgroups Table-creating function which creates a table+ #' |
||
| 169 | +21 |
- #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ #' @examples |
||
| 170 | +22 |
- #' and [rtables::summarize_row_groups()].+ #' adlb <- df_explicit_na(tern_ex_adlb) |
||
| 171 | +23 |
#' |
||
| 172 | +24 |
- #' @param df (`list`)\cr a list of data frames containing all analysis variables. List should be+ #' h_map_for_count_abnormal( |
||
| 173 | +25 |
- #' created using [extract_rsp_subgroups()].+ #' df = adlb, |
||
| 174 | +26 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
|
||
| 175 | +27 |
- #' * `n`: Total number of observations per group.+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
||
| 176 | +28 |
- #' * `n_rsp`: Number of responders per group.+ #' method = "default", |
||
| 177 | +29 |
- #' * `prop`: Proportion of responders.+ #' na_str = "<Missing>" |
||
| 178 | +30 |
- #' * `n_tot`: Total number of observations.+ #' ) |
||
| 179 | +31 |
- #' * `or`: Odds ratio.+ #' |
||
| 180 | +32 |
- #' * `ci` : Confidence interval of odds ratio.+ #' df <- data.frame( |
||
| 181 | +33 |
- #' * `pval`: p-value of the effect.+ #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
|
||
| 182 | +34 |
- #' Note, the statistics `n_tot`, `or`, and `ci` are required.+ #' AVISIT = c( |
||
| 183 | +35 |
- #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply+ #' rep("WEEK 1", 2),
|
||
| 184 | +36 |
- #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If+ #' rep("WEEK 2", 2),
|
||
| 185 | +37 |
- #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$prop$arm` will be used as `arm_x` and+ #' rep("WEEK 1", 2),
|
||
| 186 | +38 |
- #' the second level as `arm_y`.+ #' rep("WEEK 2", 2),
|
||
| 187 | +39 |
- #'+ #' rep("WEEK 1", 2),
|
||
| 188 | +40 |
- #' @return An `rtables` table summarizing binary response by subgroup.+ #' rep("WEEK 2", 2)
|
||
| 189 | +41 |
- #'+ #' ), |
||
| 190 | +42 |
- #' @examples+ #' PARAM = rep(c("ALT", "CPR"), 6),
|
||
| 191 | +43 |
- #' # Table with default columns+ #' ANRIND = c( |
||
| 192 | +44 |
- #' basic_table() %>%+ #' "NORMAL", "NORMAL", "LOW", |
||
| 193 | +45 |
- #' tabulate_rsp_subgroups(df)+ #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
|
||
| 194 | +46 |
- #'+ #' ), |
||
| 195 | +47 |
- #' # Table with selected columns+ #' ANRLO = rep(5, 12), |
||
| 196 | +48 |
- #' basic_table() %>%+ #' ANRHI = rep(20, 12) |
||
| 197 | +49 |
- #' tabulate_rsp_subgroups(+ #' ) |
||
| 198 | +50 |
- #' df = df,+ #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
|
||
| 199 | +51 |
- #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
+ #' h_map_for_count_abnormal( |
||
| 200 | +52 |
- #' )+ #' df = df, |
||
| 201 | +53 |
- #'+ #' variables = list( |
||
| 202 | +54 |
- #' # Table with risk difference column added+ #' anl = "ANRIND", |
||
| 203 | +55 |
- #' basic_table() %>%+ #' split_rows = c("PARAM"),
|
||
| 204 | +56 |
- #' tabulate_rsp_subgroups(+ #' range_low = "ANRLO", |
||
| 205 | +57 |
- #' df,+ #' range_high = "ANRHI" |
||
| 206 | +58 |
- #' riskdiff = control_riskdiff(+ #' ), |
||
| 207 | +59 |
- #' arm_x = levels(df$prop$arm)[1],+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
||
| 208 | +60 |
- #' arm_y = levels(df$prop$arm)[2]+ #' method = "range", |
||
| 209 | +61 |
- #' )+ #' na_str = "<Missing>" |
||
| 210 | +62 |
- #' )+ #' ) |
||
| 211 | +63 |
#' |
||
| 212 | +64 |
#' @export |
||
| 213 | +65 |
- #' @order 2+ h_map_for_count_abnormal <- function(df, |
||
| 214 | +66 |
- tabulate_rsp_subgroups <- function(lyt,+ variables = list( |
||
| 215 | +67 |
- df,+ anl = "ANRIND", |
||
| 216 | +68 |
- vars = c("n_tot", "n", "prop", "or", "ci"),
+ split_rows = c("PARAM"),
|
||
| 217 | +69 |
- groups_lists = list(),+ range_low = "ANRLO", |
||
| 218 | +70 |
- label_all = "All Patients",+ range_high = "ANRHI" |
||
| 219 | +71 |
- riskdiff = NULL,+ ), |
||
| 220 | +72 |
- na_str = default_na_str(),+ abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
|
||
| 221 | +73 |
- .formats = c(+ method = c("default", "range"),
|
||
| 222 | +74 |
- n = "xx", n_rsp = "xx", prop = "xx.x%", n_tot = "xx",+ na_str = "<Missing>") {
|
||
| 223 | -+ | |||
| 75 | +7x |
- or = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)),+ method <- match.arg(method) |
||
| 224 | -+ | |||
| 76 | +7x |
- pval = "x.xxxx | (<0.0001)"+ checkmate::assert_subset(c("anl", "split_rows"), names(variables))
|
||
| 225 | -+ | |||
| 77 | +7x |
- )) {
+ checkmate::assert_false(anyNA(df[variables$split_rows])) |
||
| 226 | -13x | +78 | +7x |
- checkmate::assert_list(riskdiff, null.ok = TRUE)+ assert_df_with_variables(df, |
| 227 | -13x | +79 | +7x |
- checkmate::assert_true(all(c("n_tot", "or", "ci") %in% vars))
+ variables = list(anl = variables$anl, split_rows = variables$split_rows), |
| 228 | -13x | +80 | +7x |
- if ("pval" %in% vars && !"pval" %in% names(df$or)) {
+ na_level = na_str |
| 229 | -1x | +|||
| 81 | +
- warning(+ ) |
|||
| 230 | -1x | +82 | +7x |
- 'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ',+ assert_df_with_factors(df, list(val = variables$anl)) |
| 231 | -1x | +83 | +7x |
- 'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ',+ assert_valid_factor(df[[variables$anl]], any.missing = FALSE) |
| 232 | -1x | +84 | +7x |
- 'the "method" argument to `extract_rsp_subgroups()`. If method = "cmh", strata must also be specified via the ',+ assert_list_of_variables(variables) |
| 233 | -1x | +85 | +7x |
- '"variables" argument to `extract_rsp_subgroups()`.'+ checkmate::assert_list(abnormal, types = "character", len = 2) |
| 234 | +86 |
- )+ |
||
| 235 | +87 |
- }+ # Drop usued levels from df as they are not supposed to be in the final map |
||
| 236 | -+ | |||
| 88 | +7x |
-
+ df <- droplevels(df) |
||
| 237 | +89 |
- # Create "ci" column from "lcl" and "ucl"+ |
||
| 238 | -13x | +90 | +7x |
- df$or$ci <- combine_vectors(df$or$lcl, df$or$ucl)+ normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal)) |
| 239 | +91 | |||
| 240 | +92 |
- # Fill in missing formats with defaults+ # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL" |
||
| 241 | -13x | +93 | +7x |
- default_fmts <- eval(formals(tabulate_rsp_subgroups)$.formats)+ checkmate::assert_vector(normal_value, len = 1) |
| 242 | -13x | +|||
| 94 | +
- .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]])+ |
|||
| 243 | +95 |
-
+ # Default method will only have what is observed in the df, and records with all normal values will be excluded to |
||
| 244 | +96 |
- # Extract additional parameters from df+ # avoid error in layout building. |
||
| 245 | -13x | +97 | +7x |
- conf_level <- df$or$conf_level[1]+ if (method == "default") {
|
| 246 | -13x | +98 | +3x |
- method <- if ("pval_label" %in% names(df$or)) df$or$pval_label[1] else NULL
+ df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal)) |
| 247 | -13x | +99 | +3x |
- colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)+ map <- unique(df_abnormal[c(variables$split_rows, variables$anl)]) |
| 248 | -13x | +100 | +3x |
- prop_vars <- intersect(colvars$vars, c("n", "prop", "n_rsp"))
+ map_normal <- unique(subset(map, select = variables$split_rows)) |
| 249 | -13x | +101 | +3x |
- or_vars <- intersect(names(colvars$labels), c("n_tot", "or", "ci", "pval"))
+ map_normal[[variables$anl]] <- normal_value |
| 250 | -13x | +102 | +3x |
- colvars_prop <- list(vars = prop_vars, labels = colvars$labels[prop_vars])+ map <- rbind(map, map_normal) |
| 251 | -13x | +103 | +4x |
- colvars_or <- list(vars = or_vars, labels = colvars$labels[or_vars])+ } else if (method == "range") {
|
| 252 | +104 | - - | -||
| 253 | -13x | -
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all)+ # range method follows the rule that at least one observation with ANRLO > 0 for low |
||
| 254 | +105 |
-
+ # direction and at least one observation with ANRHI is not missing for high direction. |
||
| 255 | -+ | |||
| 106 | +4x |
- # Get analysis function for each statistic+ checkmate::assert_subset(c("range_low", "range_high"), names(variables))
|
||
| 256 | -13x | +107 | +4x |
- afun_lst <- a_response_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str)+ checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
|
| 257 | +108 | |||
| 258 | -+ | |||
| 109 | +4x |
- # Add risk difference column+ assert_df_with_variables(df, |
||
| 259 | -13x | +110 | +4x |
- if (!is.null(riskdiff)) {
+ variables = list( |
| 260 | -! | +|||
| 111 | +4x |
- if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$prop$arm)[1]+ range_low = variables$range_low, |
||
| 261 | -! | +|||
| 112 | +4x |
- if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$prop$arm)[2]+ range_high = variables$range_high |
||
| 262 | -1x | +|||
| 113 | +
- colvars_or$vars <- c(colvars_or$vars, "riskdiff")+ ) |
|||
| 263 | -1x | +|||
| 114 | +
- colvars_or$labels <- c(colvars_or$labels, riskdiff = riskdiff$col_label)+ ) |
|||
| 264 | -1x | +|||
| 115 | +
- arm_cols <- paste(rep(c("n_rsp", "n_rsp", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
+
|
|||
| 265 | +116 |
-
+ # Define low direction of map |
||
| 266 | -1x | +117 | +4x |
- df_prop_diff <- df$prop %>%+ df_low <- subset(df, df[[variables$range_low]] > 0) |
| 267 | -1x | +118 | +4x |
- dplyr::select(-"prop") %>%+ map_low <- unique(df_low[variables$split_rows]) |
| 268 | -1x | +119 | +4x |
- tidyr::pivot_wider(+ low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"])) |
| 269 | -1x | +120 | +4x |
- id_cols = c("subgroup", "var", "var_label", "row_type"),
+ low_levels_df <- as.data.frame(low_levels) |
| 270 | -1x | +121 | +4x |
- names_from = "arm",+ colnames(low_levels_df) <- variables$anl |
| 271 | -1x | +122 | +4x |
- values_from = c("n", "n_rsp")
+ low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
+ |
+
| 123 | +4x | +
+ rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed+ |
+ ||
| 124 | +4x | +
+ map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE]+ |
+ ||
| 125 | +4x | +
+ map_low <- cbind(map_low, low_levels_df) |
||
| 272 | +126 |
- ) %>%+ |
||
| 273 | -1x | +|||
| 127 | +
- dplyr::rowwise() %>%+ # Define high direction of map |
|||
| 274 | -1x | +128 | +4x |
- dplyr::mutate(+ df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]])) |
| 275 | -1x | +129 | +4x |
- riskdiff = stat_propdiff_ci(+ map_high <- unique(df_high[variables$split_rows]) |
| 276 | -1x | +130 | +4x |
- x = as.list(.data[[arm_cols[1]]]),+ high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"])) |
| 277 | -1x | +131 | +4x |
- y = as.list(.data[[arm_cols[2]]]),+ high_levels_df <- as.data.frame(high_levels) |
| 278 | -1x | +132 | +4x |
- N_x = .data[[arm_cols[3]]],+ colnames(high_levels_df) <- variables$anl |
| 279 | -1x | +133 | +4x |
- N_y = .data[[arm_cols[4]]]+ high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
|
| 280 | -+ | |||
| 134 | +4x |
- )+ rownames(map_high) <- NULL |
||
| 281 | -+ | |||
| 135 | +4x |
- ) %>%+ map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE] |
||
| 282 | -1x | +136 | +4x |
- dplyr::select(-dplyr::all_of(arm_cols))+ map_high <- cbind(map_high, high_levels_df) |
| 283 | +137 | |||
| 284 | -1x | +|||
| 138 | +
- df$or <- df$or %>%+ # Define normal of map |
|||
| 285 | -1x | +139 | +4x |
- dplyr::left_join(+ map_normal <- unique(rbind(map_low, map_high)[variables$split_rows]) |
| 286 | -1x | +140 | +4x |
- df_prop_diff,+ map_normal[variables$anl] <- normal_value |
| 287 | -1x | +|||
| 141 | +
- by = c("subgroup", "var", "var_label", "row_type")
+
|
|||
| 288 | -+ | |||
| 142 | +4x |
- )+ map <- rbind(map_low, map_high, map_normal) |
||
| 289 | +143 |
} |
||
| 290 | +144 | |||
| 291 | +145 |
- # Add columns from table_prop (optional)+ # map should be all characters |
||
| 292 | -13x | +146 | +7x |
- if (length(colvars_prop$vars) > 0) {
+ map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE) |
| 293 | -12x | +|||
| 147 | +
- lyt_prop <- split_cols_by(lyt = lyt, var = "arm")+ |
|||
| 294 | -12x | +|||
| 148 | +
- lyt_prop <- split_cols_by_multivar(+ # sort the map final output by split_rows variables |
|||
| 295 | -12x | +149 | +7x |
- lyt = lyt_prop,+ for (i in rev(seq_len(length(variables$split_rows)))) {
|
| 296 | -12x | +150 | +7x |
- vars = colvars_prop$vars,+ map <- map[order(map[[i]]), ] |
| 297 | -12x | +|||
| 151 | +
- varlabels = colvars_prop$labels+ } |
|||
| 298 | -+ | |||
| 152 | +7x |
- )+ map |
||
| 299 | +153 |
-
+ } |
| 300 | +1 |
- # Add "All Patients" row+ #' Survival time point analysis |
||
| 301 | -12x | +|||
| 2 | +
- lyt_prop <- split_rows_by(+ #' |
|||
| 302 | -12x | +|||
| 3 | +
- lyt = lyt_prop,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 303 | -12x | +|||
| 4 | +
- var = "row_type",+ #' |
|||
| 304 | -12x | +|||
| 5 | +
- split_fun = keep_split_levels("content"),
+ #' The analyze function [surv_timepoint()] creates a layout element to analyze patient survival rates and difference |
|||
| 305 | -12x | +|||
| 6 | +
- nested = FALSE,+ #' of survival rates between groups at a given time point. The primary analysis variable `vars` is the time variable. |
|||
| 306 | -12x | +|||
| 7 | +
- child_labels = "hidden"+ #' Other required inputs are `time_point`, the numeric time point of interest, and `is_event`, a variable that |
|||
| 307 | +8 |
- )+ #' indicates whether or not an event has occurred. The `method` argument is used to specify whether you want to analyze |
||
| 308 | -12x | +|||
| 9 | +
- lyt_prop <- analyze_colvars(+ #' survival estimations (`"surv"`), difference in survival with the control (`"surv_diff"`), or both of these |
|||
| 309 | -12x | +|||
| 10 | +
- lyt = lyt_prop,+ #' (`"both"`). |
|||
| 310 | -12x | +|||
| 11 | +
- afun = afun_lst[names(colvars_prop$labels)],+ #' |
|||
| 311 | -12x | +|||
| 12 | +
- na_str = na_str,+ #' @inheritParams argument_convention |
|||
| 312 | -12x | +|||
| 13 | +
- extra_args = extra_args+ #' @inheritParams s_surv_time |
|||
| 313 | +14 |
- )+ #' @param time_point (`numeric(1)`)\cr survival time point of interest. |
||
| 314 | +15 |
-
+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 315 | +16 |
- # Add analysis rows+ #' [control_surv_timepoint()]. Some possible parameter options are: |
||
| 316 | -12x | +|||
| 17 | +
- if ("analysis" %in% df$prop$row_type) {
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
|||
| 317 | -11x | +|||
| 18 | +
- lyt_prop <- split_rows_by(+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
|||
| 318 | -11x | +|||
| 19 | +
- lyt = lyt_prop,+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
|||
| 319 | -11x | +|||
| 20 | +
- var = "row_type",+ #' @param method (`string`)\cr `"surv"` (survival estimations), `"surv_diff"` (difference in survival with the |
|||
| 320 | -11x | +|||
| 21 | +
- split_fun = keep_split_levels("analysis"),
+ #' control), or `"both"`. |
|||
| 321 | -11x | +|||
| 22 | +
- nested = FALSE,+ #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to |
|||
| 322 | -11x | +|||
| 23 | +
- child_labels = "hidden"+ #' avoid warnings from duplicate table names. |
|||
| 323 | +24 |
- )+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 324 | -11x | +|||
| 25 | +
- lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 325 | -11x | +|||
| 26 | +
- lyt_prop <- analyze_colvars(+ #' for that statistic's row label. |
|||
| 326 | -11x | +|||
| 27 | +
- lyt = lyt_prop,+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 327 | -11x | +|||
| 28 | +
- afun = afun_lst[names(colvars_prop$labels)],+ #' |
|||
| 328 | -11x | +|||
| 29 | +
- na_str = na_str,+ #' Options are: ``r shQuote(get_stats("surv_timepoint"))``
|
|||
| 329 | -11x | +|||
| 30 | +
- inclNAs = TRUE,+ #' |
|||
| 330 | -11x | +|||
| 31 | +
- extra_args = extra_args+ #' @name survival_timepoint |
|||
| 331 | +32 |
- )+ #' @order 1 |
||
| 332 | +33 |
- }+ NULL |
||
| 333 | +34 | |||
| 334 | -12x | +|||
| 35 | +
- table_prop <- build_table(lyt_prop, df = df$prop)+ #' @describeIn survival_timepoint Statistics function which analyzes survival rate. |
|||
| 335 | +36 |
- } else {
+ #' |
||
| 336 | -1x | +|||
| 37 | +
- table_prop <- NULL+ #' @return |
|||
| 337 | +38 |
- }+ #' * `s_surv_timepoint()` returns the statistics: |
||
| 338 | +39 |
-
+ #' * `pt_at_risk`: Patients remaining at risk. |
||
| 339 | +40 |
- # Add columns from table_or ("n_tot", "or", and "ci" required)
+ #' * `event_free_rate`: Event-free rate (%). |
||
| 340 | -13x | +|||
| 41 | +
- lyt_or <- split_cols_by(lyt = lyt, var = "arm")+ #' * `rate_se`: Standard error of event free rate. |
|||
| 341 | -13x | +|||
| 42 | +
- lyt_or <- split_cols_by_multivar(+ #' * `rate_ci`: Confidence interval for event free rate. |
|||
| 342 | -13x | +|||
| 43 | +
- lyt = lyt_or,+ #' |
|||
| 343 | -13x | +|||
| 44 | +
- vars = colvars_or$vars,+ #' @keywords internal |
|||
| 344 | -13x | +|||
| 45 | +
- varlabels = colvars_or$labels+ s_surv_timepoint <- function(df, |
|||
| 345 | +46 |
- )+ .var, |
||
| 346 | +47 |
-
+ time_point, |
||
| 347 | +48 |
- # Add "All Patients" row+ is_event, |
||
| 348 | -13x | +|||
| 49 | +
- lyt_or <- split_rows_by(+ control = control_surv_timepoint()) {
|
|||
| 349 | -13x | +50 | +23x |
- lyt = lyt_or,+ checkmate::assert_string(.var) |
| 350 | -13x | +51 | +23x |
- var = "row_type",+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 351 | -13x | +52 | +23x |
- split_fun = keep_split_levels("content"),
+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
| 352 | -13x | +53 | +23x |
- nested = FALSE,+ checkmate::assert_number(time_point) |
| 353 | -13x | +54 | +23x |
- child_labels = "hidden"+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
| 354 | +55 |
- )+ |
||
| 355 | -13x | +56 | +23x |
- lyt_or <- analyze_colvars(+ conf_type <- control$conf_type |
| 356 | -13x | +57 | +23x |
- lyt = lyt_or,+ conf_level <- control$conf_level+ |
+
| 58 | ++ | + | ||
| 357 | -13x | +59 | +23x |
- afun = afun_lst[names(colvars_or$labels)],+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
| 358 | -13x | +60 | +23x |
- na_str = na_str,+ srv_fit <- survival::survfit( |
| 359 | -13x | +61 | +23x |
- extra_args = extra_args+ formula = formula, |
| 360 | -+ | |||
| 62 | +23x |
- ) %>%+ data = df, |
||
| 361 | -13x | +63 | +23x |
- append_topleft("Baseline Risk Factors")
+ conf.int = conf_level, |
| 362 | -+ | |||
| 64 | +23x |
-
+ conf.type = conf_type |
||
| 363 | +65 |
- # Add analysis rows+ ) |
||
| 364 | -13x | +66 | +23x |
- if ("analysis" %in% df$or$row_type) {
+ s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE) |
| 365 | -12x | +67 | +23x |
- lyt_or <- split_rows_by(+ df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
|
| 366 | -12x | +68 | +23x |
- lyt = lyt_or,+ if (df_srv_fit[["n.risk"]] == 0) {
|
| 367 | -12x | +69 | +1x |
- var = "row_type",+ pt_at_risk <- event_free_rate <- rate_se <- NA_real_ |
| 368 | -12x | +70 | +1x |
- split_fun = keep_split_levels("analysis"),
+ rate_ci <- c(NA_real_, NA_real_) |
| 369 | -12x | +|||
| 71 | +
- nested = FALSE,+ } else {
|
|||
| 370 | -12x | +72 | +22x |
- child_labels = "hidden"+ pt_at_risk <- df_srv_fit$n.risk |
| 371 | -+ | |||
| 73 | +22x |
- )+ event_free_rate <- df_srv_fit$surv |
||
| 372 | -12x | +74 | +22x |
- lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)+ rate_se <- df_srv_fit$std.err |
| 373 | -12x | +75 | +22x |
- lyt_or <- analyze_colvars(+ rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)+ |
+
| 76 | ++ |
+ } |
||
| 374 | -12x | +77 | +23x |
- lyt = lyt_or,+ list( |
| 375 | -12x | +78 | +23x |
- afun = afun_lst[names(colvars_or$labels)],+ pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"), |
| 376 | -12x | +79 | +23x |
- na_str = na_str,+ event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"), |
| 377 | -12x | +80 | +23x |
- inclNAs = TRUE,+ rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"), |
| 378 | -12x | +81 | +23x |
- extra_args = extra_args+ rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level)) |
| 379 | +82 |
- )+ ) |
||
| 380 | +83 |
- }+ } |
||
| 381 | +84 | |||
| 382 | -13x | +|||
| 85 | +
- table_or <- build_table(lyt_or, df = df$or)+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
|||
| 383 | +86 |
-
+ #' when `method = "surv"`. |
||
| 384 | +87 |
- # Join tables, add forest plot attributes+ #' |
||
| 385 | -13x | +|||
| 88 | +
- n_tot_id <- match("n_tot", colvars_or$vars)
+ #' @return |
|||
| 386 | -13x | +|||
| 89 | +
- if (is.null(table_prop)) {
+ #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 387 | -1x | +|||
| 90 | +
- result <- table_or+ #' |
|||
| 388 | -1x | +|||
| 91 | +
- or_id <- match("or", colvars_or$vars)
+ #' @keywords internal |
|||
| 389 | -1x | +|||
| 92 | +
- ci_id <- match("ci", colvars_or$vars)
+ a_surv_timepoint <- make_afun( |
|||
| 390 | +93 |
- } else {
+ s_surv_timepoint, |
||
| 391 | -12x | +|||
| 94 | +
- result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])+ .indent_mods = c( |
|||
| 392 | -12x | +|||
| 95 | +
- or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
+ pt_at_risk = 0L, |
|||
| 393 | -12x | +|||
| 96 | +
- ci_id <- 1L + ncol(table_prop) + match("ci", colvars_or$vars[-n_tot_id])
+ event_free_rate = 0L, |
|||
| 394 | -12x | +|||
| 97 | +
- n_tot_id <- 1L+ rate_se = 1L, |
|||
| 395 | +98 |
- }+ rate_ci = 1L |
||
| 396 | -13x | +|||
| 99 | +
- structure(+ ), |
|||
| 397 | -13x | +|||
| 100 | +
- result,+ .formats = c( |
|||
| 398 | -13x | +|||
| 101 | +
- forest_header = paste0(levels(df$prop$arm), "\nBetter"),+ pt_at_risk = "xx", |
|||
| 399 | -13x | +|||
| 102 | +
- col_x = or_id,+ event_free_rate = "xx.xx", |
|||
| 400 | -13x | +|||
| 103 | +
- col_ci = ci_id,+ rate_se = "xx.xx", |
|||
| 401 | -13x | +|||
| 104 | +
- col_symbol_size = n_tot_id+ rate_ci = "(xx.xx, xx.xx)" |
|||
| 402 | +105 |
) |
||
| 403 | +106 |
- }+ ) |
||
| 404 | +107 | |||
| 405 | +108 |
- #' Labels for column variables in binary response by subgroup table+ #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates. |
||
| 406 | +109 |
#' |
||
| 407 | +110 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 408 | +111 |
- #'+ #' * `s_surv_timepoint_diff()` returns the statistics: |
||
| 409 | +112 |
- #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels.+ #' * `rate_diff`: Event-free rate difference between two groups. |
||
| 410 | +113 |
- #'+ #' * `rate_diff_ci`: Confidence interval for the difference. |
||
| 411 | +114 |
- #' @inheritParams argument_convention+ #' * `ztest_pval`: p-value to test the difference is 0. |
||
| 412 | +115 |
- #' @inheritParams tabulate_rsp_subgroups+ #' |
||
| 413 | +116 |
- #'+ #' @keywords internal |
||
| 414 | +117 |
- #' @return A `list` of variables to tabulate and their labels.+ s_surv_timepoint_diff <- function(df, |
||
| 415 | +118 |
- #'+ .var, |
||
| 416 | +119 |
- #' @export+ .ref_group, |
||
| 417 | +120 |
- d_rsp_subgroups_colvars <- function(vars,+ .in_ref_col, |
||
| 418 | +121 |
- conf_level = NULL,+ time_point, |
||
| 419 | +122 |
- method = NULL) {
+ control = control_surv_timepoint(), |
||
| 420 | -22x | +|||
| 123 | +
- checkmate::assert_character(vars)+ ...) {
|
|||
| 421 | -22x | +124 | +2x |
- checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
+ if (.in_ref_col) {
|
| 422 | -22x | +|||
| 125 | +! |
- checkmate::assert_subset(+ return( |
||
| 423 | -22x | +|||
| 126 | +! |
- vars,+ list( |
||
| 424 | -22x | +|||
| 127 | +! |
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
+ |
+ ||
| 128 | +! | +
+ rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ |
+ ||
| 129 | +! | +
+ ztest_pval = formatters::with_label("", "p-value (Z-test)")
|
||
| 425 | +130 |
- )+ ) |
||
| 426 | +131 |
-
+ ) |
||
| 427 | -22x | +|||
| 132 | +
- varlabels <- c(+ } |
|||
| 428 | -22x | +133 | +2x |
- n = "n",+ data <- rbind(.ref_group, df) |
| 429 | -22x | +134 | +2x |
- n_rsp = "Responders",+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
| 430 | -22x | +135 | +2x |
- prop = "Response (%)",+ res_per_group <- lapply(split(data, group), function(x) {
|
| 431 | -22x | +136 | +4x |
- n_tot = "Total n",+ s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...) |
| 432 | -22x | +|||
| 137 | +
- or = "Odds Ratio"+ }) |
|||
| 433 | +138 |
- )+ |
||
| 434 | -22x | +139 | +2x |
- colvars <- vars+ res_x <- res_per_group[[2]] |
| 435 | -+ | |||
| 140 | +2x |
-
+ res_ref <- res_per_group[[1]] |
||
| 436 | -22x | +141 | +2x |
- if ("ci" %in% colvars) {
+ rate_diff <- res_x$event_free_rate - res_ref$event_free_rate |
| 437 | -22x | +142 | +2x |
- checkmate::assert_false(is.null(conf_level))+ se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2) |
| 438 | +143 | |||
| 439 | -22x | +144 | +2x |
- varlabels <- c(+ qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2) |
| 440 | -22x | +145 | +2x |
- varlabels,+ rate_diff_ci <- rate_diff + qs * se_diff |
| 441 | -22x | +146 | +2x |
- ci = paste0(100 * conf_level, "% CI")+ ztest_pval <- if (is.na(rate_diff)) {
+ |
+
| 147 | +2x | +
+ NA |
||
| 442 | +148 |
- )+ } else {
+ |
+ ||
| 149 | +2x | +
+ 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff)) |
||
| 443 | +150 |
-
+ }+ |
+ ||
| 151 | +2x | +
+ list(+ |
+ ||
| 152 | +2x | +
+ rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),+ |
+ ||
| 153 | +2x | +
+ rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),+ |
+ ||
| 154 | +2x | +
+ ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)") |
||
| 444 | +155 |
- # The `lcl`` variable is just a placeholder available in the analysis data,+ ) |
||
| 445 | +156 |
- # it is not acutally used in the tabulation.+ } |
||
| 446 | +157 |
- # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.+ |
||
| 447 | -22x | +|||
| 158 | +
- colvars[colvars == "ci"] <- "lcl"+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
|||
| 448 | +159 |
- }+ #' when `method = "surv_diff"`. |
||
| 449 | +160 |
-
+ #' |
||
| 450 | -22x | +|||
| 161 | +
- if ("pval" %in% colvars) {
+ #' @return |
|||
| 451 | -16x | +|||
| 162 | +
- varlabels <- c(+ #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 452 | -16x | +|||
| 163 | +
- varlabels,+ #' |
|||
| 453 | -16x | +|||
| 164 | +
- pval = method+ #' @keywords internal |
|||
| 454 | +165 |
- )+ a_surv_timepoint_diff <- make_afun( |
||
| 455 | +166 |
- }+ s_surv_timepoint_diff, |
||
| 456 | +167 |
-
+ .formats = c( |
||
| 457 | -22x | +|||
| 168 | +
- list(+ rate_diff = "xx.xx", |
|||
| 458 | -22x | +|||
| 169 | +
- vars = colvars,+ rate_diff_ci = "(xx.xx, xx.xx)", |
|||
| 459 | -22x | +|||
| 170 | +
- labels = varlabels[vars]+ ztest_pval = "x.xxxx | (<0.0001)" |
|||
| 460 | +171 |
) |
||
| 461 | +172 |
- }+ ) |
| 1 | +173 |
- #' Helper function for deriving analysis datasets for select laboratory tables+ |
||
| 2 | +174 |
- #'+ #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments |
||
| 3 | +175 |
- #' @description `r lifecycle::badge("stable")`
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 4 | +176 |
#' |
||
| 5 | +177 |
- #' Helper function that merges ADSL and ADLB datasets so that missing lab test records are inserted in the+ #' @return |
||
| 6 | +178 |
- #' output dataset. Remember that `na_level` must match the needed pre-processing+ #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions, |
||
| 7 | +179 |
- #' done with [df_explicit_na()] to have the desired output.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 8 | +180 |
- #'+ #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on |
||
| 9 | +181 |
- #' @param adsl (`data.frame`)\cr ADSL data frame.+ #' the value of `method`. |
||
| 10 | +182 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ #' |
||
| 11 | +183 |
- #' @param worst_flag (named `character`)\cr worst post-baseline lab flag variable. See how this is implemented in the+ #' @examples |
||
| 12 | +184 |
- #' following examples.+ #' library(dplyr) |
||
| 13 | +185 |
- #' @param by_visit (`flag`)\cr defaults to `FALSE` to generate worst grade per patient.+ #' |
||
| 14 | +186 |
- #' If worst grade per patient per visit is specified for `worst_flag`, then+ #' adtte_f <- tern_ex_adtte %>% |
||
| 15 | +187 |
- #' `by_visit` should be `TRUE` to generate worst grade patient per visit.+ #' filter(PARAMCD == "OS") %>% |
||
| 16 | +188 |
- #' @param no_fillin_visits (named `character`)\cr visits that are not considered for post-baseline worst toxicity+ #' mutate( |
||
| 17 | +189 |
- #' grade. Defaults to `c("SCREENING", "BASELINE")`.
+ #' AVAL = day2month(AVAL), |
||
| 18 | +190 |
- #'+ #' is_event = CNSR == 0 |
||
| 19 | +191 |
- #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`,+ #' ) |
||
| 20 | +192 |
- #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when+ #' |
||
| 21 | +193 |
- #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
+ #' # Survival at given time points. |
||
| 22 | +194 |
- #'+ #' basic_table() %>% |
||
| 23 | +195 |
- #' @details In the result data missing records will be created for the following situations:+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 24 | +196 |
- #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline).+ #' add_colcounts() %>% |
||
| 25 | +197 |
- #' * Patients who do not have any post-baseline lab values.+ #' surv_timepoint( |
||
| 26 | +198 |
- #' * Patients without any post-baseline values flagged as the worst.+ #' vars = "AVAL", |
||
| 27 | +199 |
- #'+ #' var_labels = "Months", |
||
| 28 | +200 |
- #' @examples+ #' is_event = "is_event", |
||
| 29 | +201 |
- #' # `h_adsl_adlb_merge_using_worst_flag`+ #' time_point = 7 |
||
| 30 | +202 |
- #' adlb_out <- h_adsl_adlb_merge_using_worst_flag(+ #' ) %>% |
||
| 31 | +203 |
- #' tern_ex_adsl,+ #' build_table(df = adtte_f) |
||
| 32 | +204 |
- #' tern_ex_adlb,+ #' |
||
| 33 | +205 |
- #' worst_flag = c("WGRHIFL" = "Y")
+ #' # Difference in survival at given time points. |
||
| 34 | +206 |
- #' )+ #' basic_table() %>% |
||
| 35 | +207 |
- #'+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 36 | +208 |
- #' # `h_adsl_adlb_merge_using_worst_flag` by visit example+ #' add_colcounts() %>% |
||
| 37 | +209 |
- #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag(+ #' surv_timepoint( |
||
| 38 | +210 |
- #' tern_ex_adsl,+ #' vars = "AVAL", |
||
| 39 | +211 |
- #' tern_ex_adlb,+ #' var_labels = "Months", |
||
| 40 | +212 |
- #' worst_flag = c("WGRLOVFL" = "Y"),
+ #' is_event = "is_event", |
||
| 41 | +213 |
- #' by_visit = TRUE+ #' time_point = 9, |
||
| 42 | +214 |
- #' )+ #' method = "surv_diff", |
||
| 43 | +215 |
- #'+ #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
|
||
| 44 | +216 |
- #' @export+ #' ) %>% |
||
| 45 | +217 |
- h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint+ #' build_table(df = adtte_f) |
||
| 46 | +218 |
- adlb,+ #' |
||
| 47 | +219 |
- worst_flag = c("WGRHIFL" = "Y"),
+ #' # Survival and difference in survival at given time points. |
||
| 48 | +220 |
- by_visit = FALSE,+ #' basic_table() %>% |
||
| 49 | +221 |
- no_fillin_visits = c("SCREENING", "BASELINE")) {
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 50 | -5x | +|||
| 222 | +
- col_names <- names(worst_flag)+ #' add_colcounts() %>% |
|||
| 51 | -5x | +|||
| 223 | +
- filter_values <- worst_flag+ #' surv_timepoint( |
|||
| 52 | +224 |
-
+ #' vars = "AVAL", |
||
| 53 | -5x | +|||
| 225 | +
- temp <- Map(+ #' var_labels = "Months", |
|||
| 54 | -5x | +|||
| 226 | +
- function(x, y) which(adlb[[x]] == y),+ #' is_event = "is_event", |
|||
| 55 | -5x | +|||
| 227 | +
- col_names,+ #' time_point = 9, |
|||
| 56 | -5x | +|||
| 228 | +
- filter_values+ #' method = "both" |
|||
| 57 | +229 |
- )+ #' ) %>% |
||
| 58 | +230 |
-
+ #' build_table(df = adtte_f) |
||
| 59 | -5x | +|||
| 231 | +
- position_satisfy_filters <- Reduce(intersect, temp)+ #' |
|||
| 60 | +232 |
-
+ #' @export |
||
| 61 | -5x | +|||
| 233 | +
- adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb))+ #' @order 2 |
|||
| 62 | -5x | +|||
| 234 | +
- columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
+ surv_timepoint <- function(lyt, |
|||
| 63 | +235 |
-
+ vars, |
||
| 64 | -5x | +|||
| 236 | +
- adlb_f <- adlb[position_satisfy_filters, ] %>%+ time_point, |
|||
| 65 | -5x | +|||
| 237 | +
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits)+ is_event, |
|||
| 66 | -5x | +|||
| 238 | +
- adlb_f <- adlb_f[, columns_from_adlb]+ control = control_surv_timepoint(), |
|||
| 67 | +239 |
-
+ method = c("surv", "surv_diff", "both"),
|
||
| 68 | -5x | +|||
| 240 | +
- avisits_grid <- adlb %>%+ na_str = default_na_str(), |
|||
| 69 | -5x | +|||
| 241 | +
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>%+ nested = TRUE, |
|||
| 70 | -5x | +|||
| 242 | +
- dplyr::pull(.data[["AVISIT"]]) %>%+ ..., |
|||
| 71 | -5x | +|||
| 243 | +
- unique()+ table_names_suffix = "", |
|||
| 72 | +244 |
-
+ var_labels = "Time", |
||
| 73 | -5x | +|||
| 245 | +
- if (by_visit) {
+ show_labels = "visible", |
|||
| 74 | -1x | +|||
| 246 | +
- adsl_lb <- expand.grid(+ .stats = c( |
|||
| 75 | -1x | +|||
| 247 | +
- USUBJID = unique(adsl$USUBJID),+ "pt_at_risk", "event_free_rate", "rate_ci", |
|||
| 76 | -1x | +|||
| 248 | +
- AVISIT = avisits_grid,+ "rate_diff", "rate_diff_ci", "ztest_pval" |
|||
| 77 | -1x | +|||
| 249 | +
- PARAMCD = unique(adlb$PARAMCD)+ ), |
|||
| 78 | +250 |
- )+ .formats = NULL, |
||
| 79 | +251 |
-
+ .labels = NULL, |
||
| 80 | -1x | +|||
| 252 | +
- adsl_lb <- adsl_lb %>%+ .indent_mods = if (method == "both") {
|
|||
| 81 | -1x | +253 | +2x |
- dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
+ c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L)+ |
+
| 254 | ++ |
+ } else {
|
||
| 82 | -1x | +255 | +4x |
- dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ c(rate_diff_ci = 1L, ztest_pval = 1L) |
| 83 | +256 |
-
+ }) {
|
||
| 84 | -1x | +257 | +6x |
- adsl1 <- adsl[, adsl_adlb_common_columns]+ method <- match.arg(method) |
| 85 | -1x | +258 | +6x |
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ checkmate::assert_string(table_names_suffix) |
| 86 | +259 | |||
| 87 | -1x | +260 | +6x |
- by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
+ extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...) |
| 88 | +261 | |||
| 89 | -1x | -
- adlb_btoxgr <- adlb %>%- |
- ||
| 90 | -1x | +262 | +6x |
- dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
+ f <- list( |
| 91 | -1x | +263 | +6x |
- unique() %>%+ surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
| 92 | -1x | +264 | +6x |
- dplyr::rename("BTOXGR_MAP" = "BTOXGR")
+ surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
| 93 | +265 |
-
+ ) |
||
| 94 | -1x | +266 | +6x |
- adlb_out <- merge(+ .stats <- h_split_param(.stats, .stats, f = f) |
| 95 | -1x | +267 | +6x |
- adlb_f,+ .formats <- h_split_param(.formats, names(.formats), f = f) |
| 96 | -1x | +268 | +6x |
- adsl_lb,+ .labels <- h_split_param(.labels, names(.labels), f = f) |
| 97 | -1x | +269 | +6x |
- by = by_variables_from_adlb,+ .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f) |
| 98 | -1x | +|||
| 270 | +
- all = TRUE,+ |
|||
| 99 | -1x | +271 | +6x |
- sort = FALSE+ afun_surv <- make_afun( |
| 100 | -+ | |||
| 272 | +6x |
- )+ a_surv_timepoint, |
||
| 101 | -1x | +273 | +6x |
- adlb_out <- adlb_out %>%+ .stats = .stats$surv, |
| 102 | -1x | +274 | +6x |
- dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+ .formats = .formats$surv, |
| 103 | -1x | +275 | +6x |
- dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ .labels = .labels$surv, |
| 104 | -1x | +276 | +6x |
- dplyr::select(-"BTOXGR_MAP")+ .indent_mods = .indent_mods$surv |
| 105 | +277 |
-
+ ) |
||
| 106 | -1x | +|||
| 278 | +
- adlb_var_labels <- c(+ |
|||
| 107 | -1x | +279 | +6x |
- formatters::var_labels(adlb[by_variables_from_adlb]),+ afun_surv_diff <- make_afun( |
| 108 | -1x | +280 | +6x |
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ a_surv_timepoint_diff, |
| 109 | -1x | -
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])- |
- ||
| 110 | -- |
- )- |
- ||
| 111 | -+ | 281 | +6x |
- } else {
+ .stats = .stats$surv_diff, |
| 112 | -4x | +282 | +6x |
- adsl_lb <- expand.grid(+ .formats = .formats$surv_diff, |
| 113 | -4x | +283 | +6x |
- USUBJID = unique(adsl$USUBJID),+ .labels = .labels$surv_diff, |
| 114 | -4x | +284 | +6x |
- PARAMCD = unique(adlb$PARAMCD)+ .indent_mods = .indent_mods$surv_diff |
| 115 | +285 |
- )+ ) |
||
| 116 | +286 | |||
| 117 | -4x | +287 | +6x |
- adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ time_point <- extra_args$time_point |
| 118 | +288 | |||
| 119 | -4x | +289 | +6x |
- adsl1 <- adsl[, adsl_adlb_common_columns]+ for (i in seq_along(time_point)) {
|
| 120 | -4x | +290 | +6x |
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ extra_args[["time_point"]] <- time_point[i] |
| 121 | +291 | |||
| 122 | -4x | -
- by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
- |
- ||
| 123 | -+ | 292 | +6x |
-
+ if (method %in% c("surv", "both")) {
|
| 124 | +293 | 4x |
- adlb_out <- merge(+ lyt <- analyze( |
|
| 125 | +294 | 4x |
- adlb_f,+ lyt, |
|
| 126 | +295 | 4x |
- adsl_lb,+ vars, |
|
| 127 | +296 | 4x |
- by = by_variables_from_adlb,+ var_labels = paste(time_point[i], var_labels), |
|
| 128 | +297 | 4x |
- all = TRUE,+ table_names = paste0("surv_", time_point[i], table_names_suffix),
|
|
| 129 | +298 | 4x |
- sort = FALSE- |
- |
| 130 | -- |
- )- |
- ||
| 131 | -- |
-
+ show_labels = show_labels, |
||
| 132 | +299 | 4x |
- adlb_var_labels <- c(+ afun = afun_surv, |
|
| 133 | +300 | 4x |
- formatters::var_labels(adlb[by_variables_from_adlb]),+ na_str = na_str, |
|
| 134 | +301 | 4x |
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ nested = nested, |
|
| 135 | +302 | 4x |
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ extra_args = extra_args |
|
| 136 | +303 |
- )+ ) |
||
| 137 | +304 |
- }+ } |
||
| 138 | +305 | |||
| 139 | -5x | +306 | +6x |
- adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ if (method %in% c("surv_diff", "both")) {
|
| 140 | -5x | +307 | +4x |
- adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ lyt <- analyze(+ |
+
| 308 | +4x | +
+ lyt,+ |
+ ||
| 309 | +4x | +
+ vars,+ |
+ ||
| 310 | +4x | +
+ var_labels = paste(time_point[i], var_labels),+ |
+ ||
| 311 | +4x | +
+ table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
+ |
+ ||
| 312 | +4x | +
+ show_labels = ifelse(method == "both", "hidden", show_labels),+ |
+ ||
| 313 | +4x | +
+ afun = afun_surv_diff,+ |
+ ||
| 314 | +4x | +
+ na_str = na_str,+ |
+ ||
| 315 | +4x | +
+ nested = nested,+ |
+ ||
| 316 | +4x | +
+ extra_args = extra_args |
||
| 141 | +317 |
-
+ ) |
||
| 142 | -5x | +|||
| 318 | +
- formatters::var_labels(adlb_out) <- adlb_var_labels+ } |
|||
| 143 | +319 |
-
+ } |
||
| 144 | -5x | +320 | +6x |
- adlb_out+ lyt |
| 145 | +321 |
}@@ -83070,14 +79914,14 @@ tern coverage - 95.65% |
| 1 |
- #' Confidence interval for mean+ #' Control functions for Kaplan-Meier plot annotation tables |
||
| 5 |
- #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the+ #' Auxiliary functions for controlling arguments for formatting the annotation tables that can be added to plots |
||
| 6 |
- #' geometric mean. It can be used as a `ggplot` helper function for plotting.+ #' generated via [g_km()]. |
||
| 8 |
- #' @inheritParams argument_convention+ #' @param x (`proportion`)\cr x-coordinate for center of annotation table. |
||
| 9 |
- #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean.+ #' @param y (`proportion`)\cr y-coordinate for center of annotation table. |
||
| 10 |
- #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s.+ #' @param w (`proportion`)\cr relative width of the annotation table. |
||
| 11 |
- #' @param geom_mean (`flag`)\cr whether the geometric mean should be calculated.+ #' @param h (`proportion`)\cr relative height of the annotation table. |
||
| 12 |
- #'+ #' @param fill (`flag` or `character`)\cr whether the annotation table should have a background fill color. |
||
| 13 |
- #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`.+ #' Can also be a color code to use as the background fill color. If `TRUE`, color code defaults to `"#00000020"`. |
||
| 15 |
- #' @examples+ #' @return A list of components with the same names as the arguments. |
||
| 16 |
- #' stat_mean_ci(sample(10), gg_helper = FALSE)+ #' |
||
| 17 |
- #'+ #' @seealso [g_km()] |
||
| 18 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ #' |
||
| 19 |
- #' ggplot2::geom_point()+ #' @name control_annot |
||
| 20 |
- #'+ NULL |
||
| 21 |
- #' p + ggplot2::stat_summary(+ |
||
| 22 |
- #' fun.data = stat_mean_ci,+ #' @describeIn control_annot Control function for formatting the median survival time annotation table. This annotation |
||
| 23 |
- #' geom = "errorbar"+ #' table can be added in [g_km()] by setting `annot_surv_med=TRUE`, and can be configured using the |
||
| 24 |
- #' )+ #' `control_surv_med_annot()` function by setting it as the `control_annot_surv_med` argument. |
||
| 26 |
- #' p + ggplot2::stat_summary(+ #' @examples |
||
| 27 |
- #' fun.data = stat_mean_ci,+ #' control_surv_med_annot() |
||
| 28 |
- #' fun.args = list(conf_level = 0.5),+ #' |
||
| 29 |
- #' geom = "errorbar"+ #' @export |
||
| 30 |
- #' )+ control_surv_med_annot <- function(x = 0.8, y = 0.85, w = 0.32, h = 0.16, fill = TRUE) {
|
||
| 31 | -+ | 22x |
- #'+ assert_proportion_value(x) |
| 32 | -+ | 22x |
- #' p + ggplot2::stat_summary(+ assert_proportion_value(y) |
| 33 | -+ | 22x |
- #' fun.data = stat_mean_ci,+ assert_proportion_value(w) |
| 34 | -+ | 22x |
- #' fun.args = list(conf_level = 0.5, geom_mean = TRUE),+ assert_proportion_value(h) |
| 35 |
- #' geom = "errorbar"+ |
||
| 36 | -+ | 22x |
- #' )+ list(x = x, y = y, w = w, h = h, fill = fill) |
| 37 |
- #'+ } |
||
| 38 |
- #' @export+ |
||
| 39 |
- stat_mean_ci <- function(x,+ #' @describeIn control_annot Control function for formatting the Cox-PH annotation table. This annotation table can be |
||
| 40 |
- conf_level = 0.95,+ #' added in [g_km()] by setting `annot_coxph=TRUE`, and can be configured using the `control_coxph_annot()` function |
||
| 41 |
- na.rm = TRUE, # nolint+ #' by setting it as the `control_annot_coxph` argument. |
||
| 42 |
- n_min = 2,+ #' |
||
| 43 |
- gg_helper = TRUE,+ #' @param ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the |
||
| 44 |
- geom_mean = FALSE) {
+ #' annotation table. If `FALSE` (default), only comparison groups will be printed in the table labels. |
||
| 45 | -2283x | +
- if (na.rm) {
+ #' |
|
| 46 | -10x | +
- x <- stats::na.omit(x)+ #' @examples |
|
| 47 |
- }+ #' control_coxph_annot() |
||
| 48 | -2283x | +
- n <- length(x)+ #' |
|
| 49 |
-
+ #' @export |
||
| 50 | -2283x | +
- if (!geom_mean) {
+ control_coxph_annot <- function(x = 0.29, y = 0.51, w = 0.4, h = 0.125, fill = TRUE, ref_lbls = FALSE) {
|
|
| 51 | -1149x | +11x |
- m <- mean(x)+ checkmate::assert_logical(ref_lbls, any.missing = FALSE) |
| 52 |
- } else {
+
|
||
| 53 | -1134x | +11x |
- negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0)+ res <- c(control_surv_med_annot(x = x, y = y, w = w, h = h), list(ref_lbls = ref_lbls)) |
| 54 | -1134x | +11x |
- if (negative_values_exist) {
+ res |
| 55 | -22x | +
- m <- NA_real_+ } |
|
| 56 |
- } else {
+
|
||
| 57 | -1112x | +
- x <- log(x)+ #' Helper function to calculate x-tick positions |
|
| 58 | -1112x | +
- m <- mean(x)+ #' |
|
| 59 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 60 |
- }+ #' |
||
| 61 |
-
+ #' Calculate the positions of ticks on the x-axis. However, if `xticks` already |
||
| 62 | -2283x | +
- if (n < n_min || is.na(m)) {
+ #' exists it is kept as is. It is based on the same function `ggplot2` relies on, |
|
| 63 | -302x | +
- ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_)+ #' and is required in the graphic and the patient-at-risk annotation table. |
|
| 64 |
- } else {
+ #' |
||
| 65 | -1981x | +
- hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n)+ #' @inheritParams g_km |
|
| 66 | -1981x | +
- ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci)+ #' @inheritParams h_ggkm |
|
| 67 | -1981x | +
- if (geom_mean) {
+ #' |
|
| 68 | -981x | +
- ci <- exp(ci)+ #' @return A vector of positions to use for x-axis ticks on a `ggplot` object. |
|
| 69 |
- }+ #' |
||
| 70 |
- }+ #' @examples |
||
| 71 |
-
+ #' library(dplyr) |
||
| 72 | -2283x | +
- if (gg_helper) {
+ #' library(survival) |
|
| 73 | -4x | +
- m <- ifelse(is.na(m), NA_real_, m)+ #' |
|
| 74 | -4x | +
- ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]])+ #' data <- tern_ex_adtte %>% |
|
| 75 |
- }+ #' filter(PARAMCD == "OS") %>% |
||
| 76 |
-
+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 77 | -2283x | +
- return(ci)+ #' h_data_plot() |
|
| 78 |
- }+ #' |
||
| 79 |
-
+ #' h_xticks(data) |
||
| 80 |
- #' Confidence interval for median+ #' h_xticks(data, xticks = seq(0, 3000, 500)) |
||
| 81 |
- #'+ #' h_xticks(data, xticks = 500) |
||
| 82 |
- #' @description `r lifecycle::badge("stable")`
+ #' h_xticks(data, xticks = 500, max_time = 6000) |
||
| 83 |
- #'+ #' h_xticks(data, xticks = c(0, 500), max_time = 300) |
||
| 84 |
- #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper+ #' h_xticks(data, xticks = 500, max_time = 300) |
||
| 85 |
- #' function for plotting.+ #' |
||
| 86 |
- #'+ #' @export |
||
| 87 |
- #' @inheritParams argument_convention+ h_xticks <- function(data, xticks = NULL, max_time = NULL) {
|
||
| 88 | -+ | 18x |
- #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s.+ if (is.null(xticks)) {
|
| 89 | -+ | 13x |
- #'+ if (is.null(max_time)) {
|
| 90 | -+ | 11x |
- #' @details This function was adapted from `DescTools/versions/0.99.35/source`+ labeling::extended(range(data$time)[1], range(data$time)[2], m = 5) |
| 91 |
- #'+ } else {
|
||
| 92 | -+ | 2x |
- #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`.+ labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5) |
| 93 |
- #'+ } |
||
| 94 | -+ | 5x |
- #' @examples+ } else if (checkmate::test_number(xticks)) {
|
| 95 | -+ | 2x |
- #' stat_median_ci(sample(10), gg_helper = FALSE)+ if (is.null(max_time)) {
|
| 96 | -+ | 1x |
- #'+ seq(0, max(data$time), xticks) |
| 97 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ } else {
|
||
| 98 | -+ | 1x |
- #' ggplot2::geom_point()+ seq(0, max(data$time, max_time), xticks) |
| 99 |
- #' p + ggplot2::stat_summary(+ } |
||
| 100 | -+ | 3x |
- #' fun.data = stat_median_ci,+ } else if (is.numeric(xticks)) {
|
| 101 | -+ | 2x |
- #' geom = "errorbar"+ xticks |
| 102 |
- #' )+ } else {
|
||
| 103 | -+ | 1x |
- #'+ stop( |
| 104 | -+ | 1x |
- #' @export+ paste( |
| 105 | -+ | 1x |
- stat_median_ci <- function(x,+ "xticks should be either `NULL`", |
| 106 | -+ | 1x |
- conf_level = 0.95,+ "or a single number (interval between x ticks)", |
| 107 | -+ | 1x |
- na.rm = TRUE, # nolint+ "or a numeric vector (position of ticks on the x axis)" |
| 108 |
- gg_helper = TRUE) {
+ ) |
||
| 109 | -1147x | +
- x <- unname(x)+ ) |
|
| 110 | -1147x | +
- if (na.rm) {
+ } |
|
| 111 | -9x | +
- x <- x[!is.na(x)]+ } |
|
| 112 |
- }+ |
||
| 113 | -1147x | +
- n <- length(x)+ #' Helper function for survival estimations |
|
| 114 | -1147x | +
- med <- stats::median(x)+ #' |
|
| 115 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 116 | -1147x | +
- k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE)+ #' |
|
| 117 |
-
+ #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval. |
||
| 118 |
- # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range+ #' |
||
| 119 | -1147x | +
- if (k == 0 || is.na(med)) {
+ #' @inheritParams h_data_plot |
|
| 120 | -242x | +
- ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)+ #' |
|
| 121 | -242x | +
- empir_conf_level <- NA_real_+ #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
|
| 122 |
- } else {
+ #' |
||
| 123 | -905x | +
- x_sort <- sort(x)+ #' @examples |
|
| 124 | -905x | +
- ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])+ #' library(dplyr) |
|
| 125 | -905x | +
- empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5)+ #' library(survival) |
|
| 126 |
- }+ #' |
||
| 127 |
-
+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS") |
||
| 128 | -1147x | +
- if (gg_helper) {
+ #' fit <- survfit( |
|
| 129 | -4x | +
- ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]])+ #' formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, |
|
| 130 |
- }+ #' data = adtte |
||
| 131 |
-
+ #' ) |
||
| 132 | -1147x | +
- attr(ci, "conf_level") <- empir_conf_level+ #' h_tbl_median_surv(fit_km = fit) |
|
| 133 |
-
+ #' |
||
| 134 | -1147x | +
- return(ci)+ #' @export |
|
| 135 |
- }+ h_tbl_median_surv <- function(fit_km, armval = "All") {
|
||
| 136 | -+ | 10x |
-
+ y <- if (is.null(fit_km$strata)) {
|
| 137 | -+ | ! |
- #' p-Value of the mean+ as.data.frame(t(summary(fit_km)$table), row.names = armval) |
| 138 |
- #'+ } else {
|
||
| 139 | -+ | 10x |
- #' @description `r lifecycle::badge("stable")`
+ tbl <- summary(fit_km)$table |
| 140 | -+ | 10x |
- #'+ rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
|
| 141 | -+ | 10x |
- #' Convenient function for calculating the two-sided p-value of the mean.+ rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2] |
| 142 | -+ | 10x |
- #'+ as.data.frame(tbl) |
| 143 |
- #' @inheritParams argument_convention+ } |
||
| 144 | -+ | 10x |
- #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean.+ conf.int <- summary(fit_km)$conf.int # nolint |
| 145 | -+ | 10x |
- #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis.+ y$records <- round(y$records) |
| 146 | -+ | 10x |
- #'+ y$median <- signif(y$median, 4) |
| 147 | -+ | 10x |
- #' @return A p-value.+ y$`CI` <- paste0( |
| 148 | -+ | 10x |
- #'+ "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
|
| 149 |
- #' @examples+ ) |
||
| 150 | -+ | 10x |
- #' stat_mean_pval(sample(10))+ stats::setNames( |
| 151 | -+ | 10x |
- #'+ y[c("records", "median", "CI")],
|
| 152 | -+ | 10x |
- #' stat_mean_pval(rnorm(10), test_mean = 0.5)+ c("N", "Median", f_conf_level(conf.int))
|
| 153 |
- #'+ ) |
||
| 154 |
- #' @export+ } |
||
| 155 |
- stat_mean_pval <- function(x,+ |
||
| 156 |
- na.rm = TRUE, # nolint+ #' Helper function for generating a pairwise Cox-PH table |
||
| 157 |
- n_min = 2,+ #' |
||
| 158 |
- test_mean = 0) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 159 | -1147x | +
- if (na.rm) {
+ #' |
|
| 160 | -9x | +
- x <- stats::na.omit(x)+ #' Create a `data.frame` of pairwise stratified or unstratified Cox-PH analysis results. |
|
| 161 |
- }+ #' |
||
| 162 | -1147x | +
- n <- length(x)+ #' @inheritParams g_km |
|
| 163 |
-
+ #' @param annot_coxph_ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the |
||
| 164 | -1147x | +
- x_mean <- mean(x)+ #' `annot_coxph` table. If `FALSE` (default), only comparison groups will be printed in `annot_coxph` table labels. |
|
| 165 | -1147x | +
- x_sd <- stats::sd(x)+ #' |
|
| 166 |
-
+ #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
||
| 167 | -1147x | +
- if (n < n_min) {
+ #' and `p-value (log-rank)`. |
|
| 168 | -140x | +
- pv <- c(p_value = NA_real_)+ #' |
|
| 169 |
- } else {
+ #' @examples |
||
| 170 | -1007x | +
- x_se <- stats::sd(x) / sqrt(n)+ #' library(dplyr) |
|
| 171 | -1007x | +
- ttest <- (x_mean - test_mean) / x_se+ #' |
|
| 172 | -1007x | +
- pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))+ #' adtte <- tern_ex_adtte %>% |
|
| 173 |
- }+ #' filter(PARAMCD == "OS") %>% |
||
| 174 |
-
+ #' mutate(is_event = CNSR == 0) |
||
| 175 | -1147x | +
- return(pv)+ #' |
|
| 176 |
- }+ #' h_tbl_coxph_pairwise( |
||
| 177 |
-
+ #' df = adtte, |
||
| 178 |
- #' Proportion difference and confidence interval+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"), |
||
| 179 |
- #'+ #' control_coxph_pw = control_coxph(conf_level = 0.9) |
||
| 180 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 182 |
- #' Function for calculating the proportion (or risk) difference and confidence interval between arm+ #' @export |
||
| 183 |
- #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence+ h_tbl_coxph_pairwise <- function(df, |
||
| 184 |
- #' in arm Y from cumulative incidence in arm X.+ variables, |
||
| 185 |
- #'+ ref_group_coxph = NULL, |
||
| 186 |
- #' @inheritParams argument_convention+ control_coxph_pw = control_coxph(), |
||
| 187 |
- #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group).+ annot_coxph_ref_lbls = FALSE) {
|
||
| 188 | -+ | 4x |
- #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`.+ if ("strat" %in% names(variables)) {
|
| 189 | -+ | ! |
- #' @param N_x (`numeric(1)`)\cr total number of records in arm X.+ warning( |
| 190 | -+ | ! |
- #' @param N_y (`numeric(1)`)\cr total number of records in arm Y.+ "Warning: the `strat` element name of the `variables` list argument to `h_tbl_coxph_pairwise() ", |
| 191 | -+ | ! |
- #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in+ "was deprecated in tern 0.9.4.\n ", |
| 192 | -+ | ! |
- #' `x` and `y`. Must be of equal length to `x` and `y`.+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
| 193 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ ) |
||
| 194 | -+ | ! |
- #'+ variables[["strata"]] <- variables[["strat"]] |
| 195 |
- #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and+ } |
||
| 196 |
- #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound.+ |
||
| 197 | -+ | 4x |
- #'+ assert_df_with_variables(df, variables) |
| 198 | -+ | 4x |
- #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()]+ checkmate::assert_choice(ref_group_coxph, levels(df[[variables$arm]]), null.ok = TRUE) |
| 199 | -+ | 4x |
- #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing+ checkmate::assert_flag(annot_coxph_ref_lbls) |
| 200 |
- #' proportion (risk) difference to an `rtables` layout.+ |
||
| 201 | -+ | 4x |
- #'+ arm <- variables$arm |
| 202 | -+ | 4x |
- #' @examples+ df[[arm]] <- factor(df[[arm]]) |
| 203 |
- #' stat_propdiff_ci(+ |
||
| 204 | -+ | 4x |
- #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9+ ref_group <- if (!is.null(ref_group_coxph)) ref_group_coxph else levels(df[[variables$arm]])[1] |
| 205 | -+ | 4x |
- #' )+ comp_group <- setdiff(levels(df[[arm]]), ref_group) |
| 206 |
- #'+ |
||
| 207 | -+ | 4x |
- #' stat_propdiff_ci(+ results <- Map(function(comp) {
|
| 208 | -+ | 8x |
- #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE+ res <- s_coxph_pairwise( |
| 209 | -+ | 8x |
- #' )+ df = df[df[[arm]] == comp, , drop = FALSE], |
| 210 | -+ | 8x |
- #'+ .ref_group = df[df[[arm]] == ref_group, , drop = FALSE], |
| 211 | -+ | 8x |
- #' @export+ .in_ref_col = FALSE, |
| 212 | -+ | 8x |
- stat_propdiff_ci <- function(x,+ .var = variables$tte, |
| 213 | -+ | 8x |
- y,+ is_event = variables$is_event, |
| 214 | -+ | 8x |
- N_x, # nolint+ strata = variables$strata, |
| 215 | -+ | 8x |
- N_y, # nolint+ control = control_coxph_pw |
| 216 |
- list_names = NULL,+ ) |
||
| 217 | -+ | 8x |
- conf_level = 0.95,+ res_df <- data.frame( |
| 218 | -+ | 8x |
- pct = TRUE) {
+ hr = format(round(res$hr, 2), nsmall = 2), |
| 219 | -51x | +8x |
- checkmate::assert_list(x, types = "numeric")+ hr_ci = paste0( |
| 220 | -51x | +8x |
- checkmate::assert_list(y, types = "numeric", len = length(x))+ "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
|
| 221 | -51x | +8x |
- checkmate::assert_character(list_names, len = length(x), null.ok = TRUE)+ format(round(res$hr_ci[2], 2), nsmall = 2), ")" |
| 222 | -51x | +
- rd_list <- lapply(seq_along(x), function(i) {
+ ), |
|
| 223 | -134x | +8x |
- p_x <- x[[i]] / N_x+ pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4), |
| 224 | -134x | +8x |
- p_y <- y[[i]] / N_y+ stringsAsFactors = FALSE |
| 225 | -134x | +
- rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) *+ ) |
|
| 226 | -134x | +8x |
- sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y)+ colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
|
| 227 | -134x | +8x |
- c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1)+ row.names(res_df) <- comp |
| 228 | -+ | 8x |
- })+ res_df |
| 229 | -51x | +4x |
- names(rd_list) <- list_names+ }, comp_group) |
| 230 | -51x | +1x |
- rd_list+ if (annot_coxph_ref_lbls) names(results) <- paste(comp_group, "vs.", ref_group) |
| 231 |
- }+ + |
+ ||
| 232 | +4x | +
+ do.call(rbind, results) |
| 1 | +233 |
- #' Tabulate survival duration by subgroup+ } |
|||
| 2 | +234 |
- #'+ |
|||
| 3 | +235 |
- #' @description `r lifecycle::badge("stable")`
+ #' Helper function to tidy survival fit data |
|||
| 4 | +236 |
#' |
|||
| 5 | +237 |
- #' The [tabulate_survival_subgroups()] function creates a layout element to tabulate survival duration by subgroup,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 6 | +238 |
- #' returning statistics including median survival time and hazard ratio for each population subgroup. The table is+ #' |
|||
| 7 | +239 |
- #' created from `df`, a list of data frames returned by [extract_survival_subgroups()], with the statistics to include+ #' Convert the survival fit data into a data frame designed for plotting |
|||
| 8 | +240 |
- #' specified via the `vars` parameter.+ #' within `g_km`. |
|||
| 9 | +241 |
#' |
|||
| 10 | +242 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ #' This starts from the [broom::tidy()] result, and then: |
|||
| 11 | +243 |
- #'+ #' * Post-processes the `strata` column into a factor. |
|||
| 12 | +244 |
- #' @inheritParams argument_convention+ #' * Extends each stratum by an additional first row with time 0 and probability 1 so that |
|||
| 13 | +245 |
- #' @inheritParams survival_coxph_pairwise+ #' downstream plot lines start at those coordinates. |
|||
| 14 | +246 |
- #' @param df (`list`)\cr list of data frames containing all analysis variables. List should be+ #' * Adds a `censor` column. |
|||
| 15 | +247 |
- #' created using [extract_survival_subgroups()].+ #' * Filters the rows before `max_time`. |
|||
| 16 | +248 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' |
|||
| 17 | +249 |
- #' * `n_tot_events`: Total number of events per group.+ #' @inheritParams g_km |
|||
| 18 | +250 |
- #' * `n_events`: Number of events per group.+ #' @param fit_km (`survfit`)\cr result of [survival::survfit()]. |
|||
| 19 | +251 |
- #' * `n_tot`: Total number of observations per group.+ #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`. |
|||
| 20 | +252 |
- #' * `n`: Number of observations per group.+ #' |
|||
| 21 | +253 |
- #' * `median`: Median survival time.+ #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`, |
|||
| 22 | +254 |
- #' * `hr`: Hazard ratio.+ #' `conf.low`, `strata`, and `censor`. |
|||
| 23 | +255 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' |
|||
| 24 | +256 |
- #' * `pval`: p-value of the effect.+ #' @examples |
|||
| 25 | +257 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`+ #' library(dplyr) |
|||
| 26 | +258 |
- #' are required.+ #' library(survival) |
|||
| 27 | +259 |
- #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit.+ #' |
|||
| 28 | +260 |
- #'+ #' # Test with multiple arms |
|||
| 29 | +261 |
- #' @details These functions create a layout starting from a data frame which contains+ #' tern_ex_adtte %>% |
|||
| 30 | +262 |
- #' the required statistics. Tables typically used as part of forest plot.+ #' filter(PARAMCD == "OS") %>% |
|||
| 31 | +263 |
- #'+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|||
| 32 | +264 |
- #' @seealso [extract_survival_subgroups()]+ #' h_data_plot() |
|||
| 33 | +265 |
#' |
|||
| 34 | +266 |
- #' @examples+ #' # Test with single arm |
|||
| 35 | +267 |
- #' library(dplyr)+ #' tern_ex_adtte %>% |
|||
| 36 | +268 |
- #'+ #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>% |
|||
| 37 | +269 |
- #' adtte <- tern_ex_adtte+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|||
| 38 | +270 |
- #'+ #' h_data_plot(armval = "ARM B") |
|||
| 39 | +271 |
- #' # Save variable labels before data processing steps.+ #' |
|||
| 40 | +272 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' @export |
|||
| 41 | +273 |
- #'+ h_data_plot <- function(fit_km, |
|||
| 42 | +274 |
- #' adtte_f <- adtte %>%+ armval = "All", |
|||
| 43 | +275 |
- #' filter(+ max_time = NULL) {
|
|||
| 44 | -+ | ||||
| 276 | +18x |
- #' PARAMCD == "OS",+ y <- broom::tidy(fit_km) |
|||
| 45 | +277 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+
|
|||
| 46 | -+ | ||||
| 278 | +18x |
- #' SEX %in% c("M", "F")
+ if (!is.null(fit_km$strata)) {
|
|||
| 47 | -+ | ||||
| 279 | +18x |
- #' ) %>%+ fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
|
|||
| 48 | -+ | ||||
| 280 | +18x |
- #' mutate(+ strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2) |
|||
| 49 | -+ | ||||
| 281 | +18x |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
|
|||
| 50 | -+ | ||||
| 282 | +18x |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ y$strata <- factor( |
|||
| 51 | -+ | ||||
| 283 | +18x |
- #' SEX = droplevels(SEX),+ vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2), |
|||
| 52 | -+ | ||||
| 284 | +18x |
- #' AVALU = as.character(AVALU),+ levels = strata_levels |
|||
| 53 | +285 |
- #' is_event = CNSR == 0+ ) |
|||
| 54 | +286 |
- #' )+ } else {
|
|||
| 55 | -+ | ||||
| 287 | +! |
- #' labels <- c(+ y$strata <- armval |
|||
| 56 | +288 |
- #' "ARM" = adtte_labels[["ARM"]],+ } |
|||
| 57 | +289 |
- #' "SEX" = adtte_labels[["SEX"]],+ |
|||
| 58 | -+ | ||||
| 290 | +18x |
- #' "AVALU" = adtte_labels[["AVALU"]],+ y_by_strata <- split(y, y$strata) |
|||
| 59 | -+ | ||||
| 291 | +18x |
- #' "is_event" = "Event Flag"+ y_by_strata_extended <- lapply( |
|||
| 60 | -+ | ||||
| 292 | +18x |
- #' )+ y_by_strata, |
|||
| 61 | -+ | ||||
| 293 | +18x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ FUN = function(tbl) {
|
|||
| 62 | -+ | ||||
| 294 | +53x |
- #'+ first_row <- tbl[1L, ]+ |
+ |||
| 295 | +53x | +
+ first_row$time <- 0+ |
+ |||
| 296 | +53x | +
+ first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
+ |
+ |||
| 297 | +53x | +
+ first_row$n.event <- first_row$n.censor <- 0+ |
+ |||
| 298 | +53x | +
+ first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1+ |
+ |||
| 299 | +53x | +
+ first_row$std.error <- 0+ |
+ |||
| 300 | +53x | +
+ rbind(+ |
+ |||
| 301 | +53x | +
+ first_row,+ |
+ |||
| 302 | +53x | +
+ tbl |
|||
| 63 | +303 |
- #' df <- extract_survival_subgroups(+ ) |
|||
| 64 | +304 |
- #' variables = list(+ } |
|||
| 65 | +305 |
- #' tte = "AVAL",+ )+ |
+ |||
| 306 | +18x | +
+ y <- do.call(rbind, y_by_strata_extended) |
|||
| 66 | +307 |
- #' is_event = "is_event",+ + |
+ |||
| 308 | +18x | +
+ y$censor <- ifelse(y$n.censor > 0, y$estimate, NA)+ |
+ |||
| 309 | +18x | +
+ if (!is.null(max_time)) {
+ |
+ |||
| 310 | +1x | +
+ y <- y[y$time <= max(max_time), ] |
|||
| 67 | +311 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ }+ |
+ |||
| 312 | +18x | +
+ y |
|||
| 68 | +313 |
- #' ),+ } |
|||
| 69 | +314 |
- #' label_all = "Total Patients",+ |
|||
| 70 | +315 |
- #' data = adtte_f+ ## Deprecated Functions ---- |
|||
| 71 | +316 |
- #' )+ |
|||
| 72 | +317 |
- #' df+ #' Helper function to create a KM plot |
|||
| 73 | +318 |
#' |
|||
| 74 | +319 |
- #' df_grouped <- extract_survival_subgroups(+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 75 | +320 |
- #' variables = list(+ #' |
|||
| 76 | +321 |
- #' tte = "AVAL",+ #' Draw the Kaplan-Meier plot using `ggplot2`. |
|||
| 77 | +322 |
- #' is_event = "is_event",+ #' |
|||
| 78 | +323 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ #' @inheritParams g_km |
|||
| 79 | +324 |
- #' ),+ #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`. |
|||
| 80 | +325 |
- #' data = adtte_f,+ #' |
|||
| 81 | +326 |
- #' groups_lists = list(+ #' @return A `ggplot` object. |
|||
| 82 | +327 |
- #' BMRKR2 = list(+ #' |
|||
| 83 | +328 |
- #' "low" = "LOW",+ #' @examples |
|||
| 84 | +329 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' \donttest{
|
|||
| 85 | +330 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' library(dplyr) |
|||
| 86 | +331 |
- #' )+ #' library(survival) |
|||
| 87 | +332 |
- #' )+ #' |
|||
| 88 | +333 |
- #' )+ #' fit_km <- tern_ex_adtte %>% |
|||
| 89 | +334 |
- #' df_grouped+ #' filter(PARAMCD == "OS") %>% |
|||
| 90 | +335 |
- #'+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 91 | +336 |
- #' @name survival_duration_subgroups+ #' data_plot <- h_data_plot(fit_km = fit_km) |
|||
| 92 | +337 |
- #' @order 1+ #' xticks <- h_xticks(data = data_plot) |
|||
| 93 | +338 |
- NULL+ #' gg <- h_ggkm( |
|||
| 94 | +339 |
-
+ #' data = data_plot, |
|||
| 95 | +340 |
- #' Prepare survival data for population subgroups in data frames+ #' censor_show = TRUE, |
|||
| 96 | +341 |
- #'+ #' xticks = xticks, |
|||
| 97 | +342 |
- #' @description `r lifecycle::badge("stable")`
+ #' xlab = "Days", |
|||
| 98 | +343 |
- #'+ #' yval = "Survival", |
|||
| 99 | +344 |
- #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in+ #' ylab = "Survival Probability", |
|||
| 100 | +345 |
- #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list`+ #' title = "Survival" |
|||
| 101 | +346 |
- #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`,+ #' ) |
|||
| 102 | +347 |
- #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`.+ #' gg |
|||
| 103 | +348 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' } |
|||
| 104 | +349 |
#' |
|||
| 105 | +350 |
- #' @inheritParams argument_convention+ #' @export |
|||
| 106 | +351 |
- #' @inheritParams survival_duration_subgroups+ h_ggkm <- function(data, |
|||
| 107 | +352 |
- #' @inheritParams survival_coxph_pairwise+ xticks = NULL, |
|||
| 108 | +353 |
- #'+ yval = "Survival", |
|||
| 109 | +354 |
- #' @return A named `list` of two elements:+ censor_show, |
|||
| 110 | +355 |
- #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`,+ xlab, |
|||
| 111 | +356 |
- #' `var_label`, and `row_type`.+ ylab, |
|||
| 112 | +357 |
- #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`,+ ylim = NULL, |
|||
| 113 | +358 |
- #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ title, |
|||
| 114 | +359 |
- #'+ footnotes = NULL, |
|||
| 115 | +360 |
- #' @seealso [survival_duration_subgroups]+ max_time = NULL, |
|||
| 116 | +361 |
- #'+ lwd = 1, |
|||
| 117 | +362 |
- #' @export+ lty = NULL, |
|||
| 118 | +363 |
- extract_survival_subgroups <- function(variables,+ pch = 3, |
|||
| 119 | +364 |
- data,+ size = 2, |
|||
| 120 | +365 |
- groups_lists = list(),+ col = NULL, |
|||
| 121 | +366 |
- control = control_coxph(),+ ci_ribbon = FALSE, |
|||
| 122 | +367 |
- label_all = "All Patients") {
+ ggtheme = nestcolor::theme_nest()) {
|
|||
| 123 | -12x | -
- if ("strat" %in% names(variables)) {
- |
- |||
| 124 | -! | +368 | +1x |
- warning(+ lifecycle::deprecate_warn( |
|
| 125 | -! | +||||
| 369 | +1x |
- "Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ",+ "0.9.4", |
|||
| 126 | -! | +||||
| 370 | +1x |
- "was deprecated in tern 0.9.4.\n ",+ "h_ggkm()", |
|||
| 127 | -! | +||||
| 371 | +1x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
|||
| 128 | +372 |
- )+ ) |
|||
| 129 | -! | +||||
| 373 | +1x |
- variables[["strata"]] <- variables[["strat"]]+ checkmate::assert_numeric(lty, null.ok = TRUE) |
|||
| 130 | -+ | ||||
| 374 | +1x |
- }+ checkmate::assert_character(col, null.ok = TRUE) |
|||
| 131 | +375 | ||||
| 132 | -12x | +376 | +1x |
- df_survtime <- h_survtime_subgroups_df(+ if (is.null(ylim)) {
|
|
| 133 | -12x | +377 | +1x |
- variables,+ data_lims <- data |
|
| 134 | -12x | +||||
| 378 | +! |
- data,+ if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]] |
|||
| 135 | -12x | +379 | +1x |
- groups_lists = groups_lists,+ if (!is.null(max_time)) {
|
|
| 136 | -12x | +||||
| 380 | +! |
- label_all = label_all+ y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]])+ |
+ |||
| 381 | +! | +
+ y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]]) |
|||
| 137 | +382 |
- )+ } else {
|
|||
| 138 | -12x | +383 | +1x |
- df_hr <- h_coxph_subgroups_df(+ y_lwr <- min(data_lims[["estimate"]]) |
|
| 139 | -12x | +384 | +1x |
- variables,+ y_upr <- max(data_lims[["estimate"]]) |
|
| 140 | -12x | +||||
| 385 | +
- data,+ } |
||||
| 141 | -12x | +386 | +1x |
- groups_lists = groups_lists,+ ylim <- c(y_lwr, y_upr) |
|
| 142 | -12x | +||||
| 387 | +
- control = control,+ } |
||||
| 143 | -12x | +388 | +1x |
- label_all = label_all+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE) |
|
| 144 | +389 |
- )+ |
|||
| 145 | +390 |
-
+ # change estimates of survival to estimates of failure (1 - survival) |
|||
| 146 | -12x | +391 | +1x |
- list(survtime = df_survtime, hr = df_hr)+ if (yval == "Failure") {
|
|
| 147 | -+ | ||||
| 392 | +! |
- }+ data$estimate <- 1 - data$estimate |
|||
| 148 | -+ | ||||
| 393 | +! |
-
+ data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
|
|||
| 149 | -+ | ||||
| 394 | +! |
- #' @describeIn survival_duration_subgroups Formatted analysis function which is used as+ data$censor <- 1 - data$censor |
|||
| 150 | +395 |
- #' `afun` in `tabulate_survival_subgroups()`.+ } |
|||
| 151 | +396 |
- #'+ |
|||
| 152 | -+ | ||||
| 397 | +1x |
- #' @return+ gg <- {
|
|||
| 153 | -+ | ||||
| 398 | +1x |
- #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ ggplot2::ggplot( |
|||
| 154 | -+ | ||||
| 399 | +1x |
- #'+ data = data, |
|||
| 155 | -+ | ||||
| 400 | +1x |
- #' @keywords internal+ mapping = ggplot2::aes( |
|||
| 156 | -+ | ||||
| 401 | +1x |
- a_survival_subgroups <- function(.formats = list( # nolint start+ x = .data[["time"]], |
|||
| 157 | -+ | ||||
| 402 | +1x |
- n = "xx",+ y = .data[["estimate"]], |
|||
| 158 | -+ | ||||
| 403 | +1x |
- n_events = "xx",+ ymin = .data[["conf.low"]], |
|||
| 159 | -+ | ||||
| 404 | +1x |
- n_tot_events = "xx",+ ymax = .data[["conf.high"]], |
|||
| 160 | -+ | ||||
| 405 | +1x |
- median = "xx.x",+ color = .data[["strata"]], |
|||
| 161 | -+ | ||||
| 406 | +1x |
- n_tot = "xx",+ fill = .data[["strata"]] |
|||
| 162 | +407 |
- hr = list(format_extreme_values(2L)),+ ) |
|||
| 163 | +408 |
- ci = list(format_extreme_values_ci(2L)),+ ) + |
|||
| 164 | -+ | ||||
| 409 | +1x |
- pval = "x.xxxx | (<0.0001)"+ ggplot2::geom_hline(yintercept = 0) |
|||
| 165 | +410 |
- ),+ } |
|||
| 166 | +411 |
- na_str = default_na_str()) { # nolint end
- |
- |||
| 167 | -21x | -
- checkmate::assert_list(.formats)- |
- |||
| 168 | -21x | -
- checkmate::assert_subset(+ |
|||
| 169 | -21x | +412 | +1x |
- names(.formats),+ if (ci_ribbon) {
|
|
| 170 | -21x | +||||
| 413 | +! |
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval", "riskdiff")
+ gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0) |
|||
| 171 | +414 |
- )+ } |
|||
| 172 | +415 | ||||
| 173 | -21x | +416 | +1x |
- afun_lst <- Map(+ gg <- if (is.null(lty)) {
|
|
| 174 | -21x | +417 | +1x |
- function(stat, fmt, na_str) {
+ gg + |
|
| 175 | -160x | +418 | +1x |
- function(df, labelstr = "", ...) {
+ ggplot2::geom_step(linewidth = lwd) |
|
| 176 | -312x | +419 | +1x |
- in_rows(+ } else if (checkmate::test_number(lty)) {
|
|
| 177 | -312x | +||||
| 420 | +! |
- .list = as.list(df[[stat]]),+ gg + |
|||
| 178 | -312x | +||||
| 421 | +! |
- .labels = as.character(df$subgroup),+ ggplot2::geom_step(linewidth = lwd, lty = lty) |
|||
| 179 | -312x | +422 | +1x |
- .formats = fmt,+ } else if (is.numeric(lty)) {
|
|
| 180 | -312x | +||||
| 423 | +! |
- .format_na_strs = na_str+ gg + |
|||
| 181 | -+ | ||||
| 424 | +! |
- )+ ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ |
+ |||
| 425 | +! | +
+ ggplot2::scale_linetype_manual(values = lty) |
|||
| 182 | +426 |
- }+ } |
|||
| 183 | +427 |
- },+ |
|||
| 184 | -21x | +428 | +1x |
- stat = names(.formats),+ gg <- gg + |
|
| 185 | -21x | +429 | +1x |
- fmt = .formats,+ ggplot2::coord_cartesian(ylim = ylim) + |
|
| 186 | -21x | +430 | +1x |
- na_str = na_str+ ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes) |
|
| 187 | +431 |
- )+ |
|||
| 188 | -+ | ||||
| 432 | +1x |
-
+ if (!is.null(col)) {
|
|||
| 189 | -21x | +||||
| 433 | +! |
- afun_lst+ gg <- gg ++ |
+ |||
| 434 | +! | +
+ ggplot2::scale_color_manual(values = col) ++ |
+ |||
| 435 | +! | +
+ ggplot2::scale_fill_manual(values = col) |
|||
| 190 | +436 |
- }+ }+ |
+ |||
| 437 | +1x | +
+ if (censor_show) {
+ |
+ |||
| 438 | +1x | +
+ dt <- data[data$n.censor != 0, ]+ |
+ |||
| 439 | +1x | +
+ dt$censor_lbl <- factor("Censored")
|
|||
| 191 | +440 | ||||
| 192 | -+ | ||||
| 441 | +1x |
- #' @describeIn survival_duration_subgroups Table-creating function which creates a table+ gg <- gg + ggplot2::geom_point( |
|||
| 193 | -+ | ||||
| 442 | +1x |
- #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ data = dt, |
|||
| 194 | -+ | ||||
| 443 | +1x |
- #' and [rtables::summarize_row_groups()].+ ggplot2::aes( |
|||
| 195 | -+ | ||||
| 444 | +1x |
- #'+ x = .data[["time"]], |
|||
| 196 | -+ | ||||
| 445 | +1x |
- #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
+ y = .data[["censor"]], |
|||
| 197 | -+ | ||||
| 446 | +1x |
- #' [extract_survival_subgroups()] function when creating `df`.+ shape = .data[["censor_lbl"]] |
|||
| 198 | +447 |
- #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply+ ), |
|||
| 199 | -+ | ||||
| 448 | +1x |
- #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If+ size = size, |
|||
| 200 | -+ | ||||
| 449 | +1x |
- #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$survtime$arm` will be used as `arm_x`+ show.legend = TRUE, |
|||
| 201 | -+ | ||||
| 450 | +1x |
- #' and the second level as `arm_y`.+ inherit.aes = TRUE |
|||
| 202 | +451 |
- #'+ ) + |
|||
| 203 | -+ | ||||
| 452 | +1x |
- #' @return An `rtables` table summarizing survival by subgroup.+ ggplot2::scale_shape_manual(name = NULL, values = pch) + |
|||
| 204 | -+ | ||||
| 453 | +1x |
- #'+ ggplot2::guides( |
|||
| 205 | -+ | ||||
| 454 | +1x |
- #' @examples+ shape = ggplot2::guide_legend(override.aes = list(linetype = NA)), |
|||
| 206 | -+ | ||||
| 455 | +1x |
- #' ## Table with default columns.+ fill = ggplot2::guide_legend(override.aes = list(shape = NA)) |
|||
| 207 | +456 |
- #' basic_table() %>%+ ) |
|||
| 208 | +457 |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ } |
|||
| 209 | +458 |
- #'+ |
|||
| 210 | -+ | ||||
| 459 | +1x |
- #' ## Table with a manually chosen set of columns: adding "pval".+ if (!is.null(max_time) && !is.null(xticks)) {
|
|||
| 211 | -+ | ||||
| 460 | +! |
- #' basic_table() %>%+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))))+ |
+ |||
| 461 | +1x | +
+ } else if (!is.null(xticks)) {
+ |
+ |||
| 462 | +1x | +
+ if (max(data$time) <= max(xticks)) {
+ |
+ |||
| 463 | +1x | +
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks))) |
|||
| 212 | +464 |
- #' tabulate_survival_subgroups(+ } else {
+ |
+ |||
| 465 | +! | +
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks) |
|||
| 213 | +466 |
- #' df = df,+ }+ |
+ |||
| 467 | +! | +
+ } else if (!is.null(max_time)) {
+ |
+ |||
| 468 | +! | +
+ gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time)) |
|||
| 214 | +469 |
- #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
+ } |
|||
| 215 | +470 |
- #' time_unit = adtte_f$AVALU[1]+ + |
+ |||
| 471 | +1x | +
+ if (!is.null(ggtheme)) {
+ |
+ |||
| 472 | +1x | +
+ gg <- gg + ggtheme |
|||
| 216 | +473 |
- #' )+ } |
|||
| 217 | +474 |
- #'+ + |
+ |||
| 475 | +1x | +
+ gg + ggplot2::theme(+ |
+ |||
| 476 | +1x | +
+ legend.position = "bottom",+ |
+ |||
| 477 | +1x | +
+ legend.title = ggplot2::element_blank(),+ |
+ |||
| 478 | +1x | +
+ legend.key.height = unit(0.02, "npc"),+ |
+ |||
| 479 | +1x | +
+ panel.grid.major.x = ggplot2::element_line(linewidth = 2) |
|||
| 218 | +480 |
- #' @export+ ) |
|||
| 219 | +481 |
- #' @order 2+ } |
|||
| 220 | +482 |
- tabulate_survival_subgroups <- function(lyt,+ |
|||
| 221 | +483 |
- df,+ #' `ggplot` decomposition |
|||
| 222 | +484 |
- vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
+ #' |
|||
| 223 | +485 |
- groups_lists = list(),+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 224 | +486 |
- label_all = lifecycle::deprecated(),+ #' |
|||
| 225 | +487 |
- time_unit = NULL,+ #' The elements composing the `ggplot` are extracted and organized in a `list`. |
|||
| 226 | +488 |
- riskdiff = NULL,+ #' |
|||
| 227 | +489 |
- na_str = default_na_str(),+ #' @param gg (`ggplot`)\cr a graphic to decompose. |
|||
| 228 | +490 |
- .formats = c(+ #' |
|||
| 229 | +491 |
- n = "xx", n_events = "xx", n_tot_events = "xx", median = "xx.x", n_tot = "xx",+ #' @return A named `list` with elements: |
|||
| 230 | +492 |
- hr = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)),+ #' * `panel`: The panel. |
|||
| 231 | +493 |
- pval = "x.xxxx | (<0.0001)"+ #' * `yaxis`: The y-axis. |
|||
| 232 | +494 |
- )) {
+ #' * `xaxis`: The x-axis. |
|||
| 233 | -10x | +||||
| 495 | +
- checkmate::assert_list(riskdiff, null.ok = TRUE)+ #' * `xlab`: The x-axis label. |
||||
| 234 | -10x | +||||
| 496 | +
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ #' * `ylab`: The y-axis label. |
||||
| 235 | -10x | +||||
| 497 | +
- checkmate::assert_true(all(c("hr", "ci") %in% vars))
+ #' * `guide`: The legend. |
||||
| 236 | +498 |
-
+ #' |
|||
| 237 | -10x | +||||
| 499 | +
- if (lifecycle::is_present(label_all)) {
+ #' @examples |
||||
| 238 | -1x | +||||
| 500 | +
- lifecycle::deprecate_warn(+ #' \donttest{
|
||||
| 239 | -1x | +||||
| 501 | +
- "0.9.5", "tabulate_survival_subgroups(label_all)",+ #' library(dplyr) |
||||
| 240 | -1x | +||||
| 502 | +
- details =+ #' library(survival) |
||||
| 241 | -1x | +||||
| 503 | +
- "Please assign the `label_all` parameter within the `extract_survival_subgroups()` function when creating `df`."+ #' library(grid) |
||||
| 242 | +504 |
- )+ #' |
|||
| 243 | +505 |
- }+ #' fit_km <- tern_ex_adtte %>% |
|||
| 244 | +506 |
-
+ #' filter(PARAMCD == "OS") %>% |
|||
| 245 | +507 |
- # Create "ci" column from "lcl" and "ucl"+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 246 | -10x | +||||
| 508 | +
- df$hr$ci <- combine_vectors(df$hr$lcl, df$hr$ucl)+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||||
| 247 | +509 |
-
+ #' xticks <- h_xticks(data = data_plot) |
|||
| 248 | +510 |
- # Fill in missing formats with defaults+ #' gg <- h_ggkm( |
|||
| 249 | -10x | +||||
| 511 | +
- default_fmts <- eval(formals(tabulate_survival_subgroups)$.formats)+ #' data = data_plot, |
||||
| 250 | -10x | +||||
| 512 | +
- .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]])+ #' yval = "Survival", |
||||
| 251 | +513 |
-
+ #' censor_show = TRUE, |
|||
| 252 | +514 |
- # Extract additional parameters from df+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
|||
| 253 | -10x | +||||
| 515 | +
- conf_level <- df$hr$conf_level[1]+ #' title = "tt", |
||||
| 254 | -10x | +||||
| 516 | +
- method <- df$hr$pval_label[1]+ #' footnotes = "ff" |
||||
| 255 | -10x | +||||
| 517 | +
- colvars <- d_survival_subgroups_colvars(vars, conf_level = conf_level, method = method, time_unit = time_unit)+ #' ) |
||||
| 256 | -10x | +||||
| 518 | +
- survtime_vars <- intersect(colvars$vars, c("n", "n_events", "median"))
+ #' |
||||
| 257 | -10x | +||||
| 519 | +
- hr_vars <- intersect(names(colvars$labels), c("n_tot", "n_tot_events", "hr", "ci", "pval"))
+ #' g_el <- h_decompose_gg(gg) |
||||
| 258 | -10x | +||||
| 520 | +
- colvars_survtime <- list(vars = survtime_vars, labels = colvars$labels[survtime_vars])+ #' grid::grid.newpage() |
||||
| 259 | -10x | +||||
| 521 | +
- colvars_hr <- list(vars = hr_vars, labels = colvars$labels[hr_vars])+ #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5)) |
||||
| 260 | +522 |
-
+ #' grid::grid.draw(g_el$panel) |
|||
| 261 | -10x | +||||
| 523 | +
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method)+ #' |
||||
| 262 | +524 |
-
+ #' grid::grid.newpage() |
|||
| 263 | +525 |
- # Get analysis function for each statistic+ #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5)) |
|||
| 264 | -10x | +||||
| 526 | +
- afun_lst <- a_survival_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str)+ #' grid::grid.draw(with(g_el, cbind(ylab, yaxis))) |
||||
| 265 | +527 |
-
+ #' } |
|||
| 266 | +528 |
- # Add risk difference column+ #' |
|||
| 267 | -10x | +||||
| 529 | +
- if (!is.null(riskdiff)) {
+ #' @export |
||||
| 268 | -1x | +||||
| 530 | +
- if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$survtime$arm)[1]+ h_decompose_gg <- function(gg) {
|
||||
| 269 | +531 | 1x |
- if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$survtime$arm)[2]+ lifecycle::deprecate_warn( |
||
| 270 | +532 | 1x |
- colvars_hr$vars <- c(colvars_hr$vars, "riskdiff")+ "0.9.4", |
||
| 271 | +533 | 1x |
- colvars_hr$labels <- c(colvars_hr$labels, riskdiff = riskdiff$col_label)+ "h_decompose_gg()", |
||
| 272 | +534 | 1x |
- arm_cols <- paste(rep(c("n_events", "n_events", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 273 | +535 |
-
+ ) |
|||
| 274 | +536 | 1x |
- df_prop_diff <- df$survtime %>%+ g_el <- ggplot2::ggplotGrob(gg) |
||
| 275 | +537 | 1x |
- dplyr::select(-"median") %>%+ y <- c( |
||
| 276 | +538 | 1x |
- tidyr::pivot_wider(+ panel = "panel", |
||
| 277 | +539 | 1x |
- id_cols = c("subgroup", "var", "var_label", "row_type"),
+ yaxis = "axis-l", |
||
| 278 | +540 | 1x |
- names_from = "arm",+ xaxis = "axis-b", |
||
| 279 | +541 | 1x |
- values_from = c("n", "n_events")
- |
- ||
| 280 | -- |
- ) %>%+ xlab = "xlab-b", |
|||
| 281 | +542 | 1x |
- dplyr::rowwise() %>%+ ylab = "ylab-l", |
||
| 282 | +543 | 1x |
- dplyr::mutate(+ guide = "guide" |
||
| 283 | -1x | +||||
| 544 | +
- riskdiff = stat_propdiff_ci(+ ) |
||||
| 284 | +545 | 1x |
- x = as.list(.data[[arm_cols[1]]]),+ lapply(X = y, function(x) gtable::gtable_filter(g_el, x)) |
||
| 285 | -1x | +||||
| 546 | +
- y = as.list(.data[[arm_cols[2]]]),+ } |
||||
| 286 | -1x | +||||
| 547 | +
- N_x = .data[[arm_cols[3]]],+ |
||||
| 287 | -1x | +||||
| 548 | +
- N_y = .data[[arm_cols[4]]]+ #' Helper function to prepare a KM layout |
||||
| 288 | +549 |
- )+ #' |
|||
| 289 | +550 |
- ) %>%+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 290 | -1x | +||||
| 551 | +
- dplyr::select(-dplyr::all_of(arm_cols))+ #' |
||||
| 291 | +552 |
-
+ #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve. |
|||
| 292 | -1x | +||||
| 553 | +
- df$hr <- df$hr %>%+ #' |
||||
| 293 | -1x | +||||
| 554 | +
- dplyr::left_join(+ #' @inheritParams g_km |
||||
| 294 | -1x | +||||
| 555 | +
- df_prop_diff,+ #' @inheritParams h_ggkm |
||||
| 295 | -1x | +||||
| 556 | +
- by = c("subgroup", "var", "var_label", "row_type")
+ #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`. |
||||
| 296 | +557 |
- )+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of |
|||
| 297 | +558 |
- }+ #' patient at risk matching the main grid of the Kaplan-Meier curve. |
|||
| 298 | +559 |
-
+ #' |
|||
| 299 | +560 |
- # Add columns from table_survtime (optional)+ #' @return A grid layout. |
|||
| 300 | -10x | +||||
| 561 | +
- if (length(colvars_survtime$vars) > 0) {
+ #' |
||||
| 301 | -9x | +||||
| 562 | +
- lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")+ #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the |
||||
| 302 | -9x | +||||
| 563 | +
- lyt_survtime <- split_rows_by(+ #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space. |
||||
| 303 | -9x | +||||
| 564 | +
- lyt = lyt_survtime,+ #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient |
||||
| 304 | -9x | +||||
| 565 | +
- var = "row_type",+ #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of |
||||
| 305 | -9x | +||||
| 566 | +
- split_fun = keep_split_levels("content"),
+ #' the strata name. |
||||
| 306 | -9x | +||||
| 567 | +
- nested = FALSE+ #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table. |
||||
| 307 | +568 |
- )+ #' |
|||
| 308 | +569 |
-
+ #' @examples |
|||
| 309 | +570 |
- # Add "All Patients" row+ #' \donttest{
|
|||
| 310 | -9x | +||||
| 571 | +
- lyt_survtime <- summarize_row_groups(+ #' library(dplyr) |
||||
| 311 | -9x | +||||
| 572 | +
- lyt = lyt_survtime,+ #' library(survival) |
||||
| 312 | -9x | +||||
| 573 | +
- var = "var_label",+ #' library(grid) |
||||
| 313 | -9x | +||||
| 574 | +
- cfun = afun_lst[names(colvars_survtime$labels)],+ #' |
||||
| 314 | -9x | +||||
| 575 | +
- na_str = na_str,+ #' fit_km <- tern_ex_adtte %>% |
||||
| 315 | -9x | +||||
| 576 | +
- extra_args = extra_args+ #' filter(PARAMCD == "OS") %>% |
||||
| 316 | +577 |
- )+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 317 | -9x | +||||
| 578 | +
- lyt_survtime <- split_cols_by_multivar(+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||||
| 318 | -9x | +||||
| 579 | +
- lyt = lyt_survtime,+ #' xticks <- h_xticks(data = data_plot) |
||||
| 319 | -9x | +||||
| 580 | +
- vars = colvars_survtime$vars,+ #' gg <- h_ggkm( |
||||
| 320 | -9x | +||||
| 581 | +
- varlabels = colvars_survtime$labels+ #' data = data_plot, |
||||
| 321 | +582 |
- )+ #' censor_show = TRUE, |
|||
| 322 | +583 |
-
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
|||
| 323 | +584 |
- # Add analysis rows+ #' title = "tt", footnotes = "ff", yval = "Survival" |
|||
| 324 | -9x | +||||
| 585 | +
- if ("analysis" %in% df$survtime$row_type) {
+ #' ) |
||||
| 325 | -8x | +||||
| 586 | +
- lyt_survtime <- split_rows_by(+ #' g_el <- h_decompose_gg(gg) |
||||
| 326 | -8x | +||||
| 587 | +
- lyt = lyt_survtime,+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
||||
| 327 | -8x | +||||
| 588 | +
- var = "row_type",+ #' grid.show.layout(lyt) |
||||
| 328 | -8x | +||||
| 589 | +
- split_fun = keep_split_levels("analysis"),
+ #' } |
||||
| 329 | -8x | +||||
| 590 | +
- nested = FALSE,+ #' |
||||
| 330 | -8x | +||||
| 591 | +
- child_labels = "hidden"+ #' @export |
||||
| 331 | +592 |
- )+ h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
|
|||
| 332 | -8x | +593 | +1x |
- lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)+ lifecycle::deprecate_warn( |
|
| 333 | -8x | +594 | +1x |
- lyt_survtime <- analyze_colvars(+ "0.9.4", |
|
| 334 | -8x | +595 | +1x |
- lyt = lyt_survtime,+ "h_km_layout()", |
|
| 335 | -8x | +596 | +1x |
- afun = afun_lst[names(colvars_survtime$labels)],+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
|
| 336 | -8x | +||||
| 597 | +
- na_str = na_str,+ ) |
||||
| 337 | -8x | -
- inclNAs = TRUE,+ | 598 | +1x | +
+ txtlines <- levels(as.factor(data$strata)) |
| 338 | -8x | +599 | +1x |
- extra_args = extra_args+ nlines <- nlevels(as.factor(data$strata)) |
|
| 339 | -+ | ||||
| 600 | +1x |
- )+ col_annot_width <- max( |
|||
| 340 | -+ | ||||
| 601 | +1x |
- }+ c( |
|||
| 341 | -+ | ||||
| 602 | +1x |
-
+ as.numeric(grid::convertX(g_el$yaxis$widths + g_el$ylab$widths, "pt")), |
|||
| 342 | -9x | +603 | +1x |
- table_survtime <- build_table(lyt_survtime, df = df$survtime)+ as.numeric( |
|
| 343 | -+ | ||||
| 604 | +1x |
- } else {
+ grid::convertX( |
|||
| 344 | +605 | 1x |
- table_survtime <- NULL+ grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt" |
||
| 345 | +606 |
- }+ ) |
|||
| 346 | +607 |
-
+ ) |
|||
| 347 | +608 |
- # Add columns from table_hr ("n_tot_events" or "n_tot", "or" and "ci" required)
- |
- |||
| 348 | -10x | -
- lyt_hr <- split_cols_by(lyt = lyt, var = "arm")- |
- |||
| 349 | -10x | -
- lyt_hr <- split_rows_by(- |
- |||
| 350 | -10x | -
- lyt = lyt_hr,- |
- |||
| 351 | -10x | -
- var = "row_type",- |
- |||
| 352 | -10x | -
- split_fun = keep_split_levels("content"),
- |
- |||
| 353 | -10x | -
- nested = FALSE+ ) |
|||
| 354 | +609 |
) |
|||
| 355 | -10x | +||||
| 610 | +
- lyt_hr <- summarize_row_groups(+ |
||||
| 356 | -10x | +611 | +1x |
- lyt = lyt_hr,+ ttl_row <- as.numeric(!is.null(title)) |
|
| 357 | -10x | +612 | +1x |
- var = "var_label",+ foot_row <- as.numeric(!is.null(footnotes)) |
|
| 358 | -10x | +613 | +1x |
- cfun = afun_lst[names(colvars_hr$labels)],+ no_tbl_ind <- c() |
|
| 359 | -10x | +614 | +1x |
- na_str = na_str,+ ht_x <- c() |
|
| 360 | -10x | +615 | +1x |
- extra_args = extra_args+ ht_units <- c() |
|
| 361 | +616 |
- )+ |
|||
| 362 | -10x | +617 | +1x |
- lyt_hr <- split_cols_by_multivar(+ if (ttl_row == 1) {
|
|
| 363 | -10x | +618 | +1x |
- lyt = lyt_hr,+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
|
| 364 | -10x | +619 | +1x |
- vars = colvars_hr$vars,+ ht_x <- c(ht_x, 2) |
|
| 365 | -10x | +620 | +1x |
- varlabels = colvars_hr$labels+ ht_units <- c(ht_units, "lines") |
|
| 366 | +621 |
- ) %>%- |
- |||
| 367 | -10x | -
- append_topleft("Baseline Risk Factors")
+ } |
|||
| 368 | +622 | ||||
| 369 | -+ | ||||
| 623 | +1x |
- # Add analysis rows+ no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2)) |
|||
| 370 | -10x | +624 | +1x |
- if ("analysis" %in% df$survtime$row_type) {
+ ht_x <- c( |
|
| 371 | -9x | +625 | +1x |
- lyt_hr <- split_rows_by(+ ht_x, |
|
| 372 | -9x | +626 | +1x |
- lyt = lyt_hr,+ 1, |
|
| 373 | -9x | +627 | +1x |
- var = "row_type",+ grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") + grid::unit(5, "pt"), |
|
| 374 | -9x | +628 | +1x |
- split_fun = keep_split_levels("analysis"),
+ grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"), |
|
| 375 | -9x | +629 | +1x |
- nested = FALSE,+ 1, |
|
| 376 | -9x | +630 | +1x |
- child_labels = "hidden"+ nlines + 0.5,+ |
+ |
| 631 | +1x | +
+ grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") |
|||
| 377 | +632 |
- )+ ) |
|||
| 378 | -9x | +633 | +1x |
- lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)+ ht_units <- c( |
|
| 379 | -9x | +634 | +1x |
- lyt_hr <- analyze_colvars(+ ht_units, |
|
| 380 | -9x | +635 | +1x |
- lyt = lyt_hr,+ "null", |
|
| 381 | -9x | +636 | +1x |
- afun = afun_lst[names(colvars_hr$labels)],+ "pt", |
|
| 382 | -9x | +637 | +1x |
- na_str = na_str,+ "pt", |
|
| 383 | -9x | +638 | +1x |
- inclNAs = TRUE,+ "lines", |
|
| 384 | -9x | +639 | +1x |
- extra_args = extra_args+ "lines", |
|
| 385 | -+ | ||||
| 640 | +1x |
- )+ "pt" |
|||
| 386 | +641 |
- }+ ) |
|||
| 387 | +642 | ||||
| 388 | -10x | +643 | +1x |
- table_hr <- build_table(lyt_hr, df = df$hr)+ if (foot_row == 1) {
|
|
| 389 | -+ | ||||
| 644 | +1x |
-
+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
|||
| 390 | -+ | ||||
| 645 | +1x |
- # Join tables, add forest plot attributes+ ht_x <- c(ht_x, 1) |
|||
| 391 | -10x | +646 | +1x |
- n_tot_ids <- grep("^n_tot", colvars_hr$vars)
+ ht_units <- c(ht_units, "lines") |
|
| 392 | -10x | +||||
| 647 | +
- if (is.null(table_survtime)) {
+ } |
||||
| 393 | +648 | 1x |
- result <- table_hr+ if (annot_at_risk) {
|
||
| 394 | +649 | 1x |
- hr_id <- match("hr", colvars_hr$vars)
+ no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row) |
||
| 395 | +650 | 1x |
- ci_id <- match("ci", colvars_hr$vars)
- |
- ||
| 396 | -- |
- } else {
+ if (!annot_at_risk_title) {
|
|||
| 397 | -9x | +||||
| 651 | +! |
- result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])+ no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE |
|||
| 398 | -9x | +||||
| 652 | +
- hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
+ } |
||||
| 399 | -9x | +||||
| 653 | +
- ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("ci", colvars_hr$vars[-n_tot_ids])
+ } else {
|
||||
| 400 | -9x | +||||
| 654 | +! |
- n_tot_ids <- seq_along(n_tot_ids)+ no_at_risk_tbl <- no_tbl_ind |
|||
| 401 | +655 |
} |
|||
| 402 | -10x | +||||
| 656 | +
- structure(+ |
||||
| 403 | -10x | +657 | +1x |
- result,+ grid::grid.layout( |
|
| 404 | -10x | +658 | +1x |
- forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ nrow = sum(no_at_risk_tbl), ncol = 2, |
|
| 405 | -10x | +659 | +1x |
- col_x = hr_id,+ widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
|
|
| 406 | -10x | +660 | +1x |
- col_ci = ci_id,+ heights = grid::unit( |
|
| 407 | -10x | +661 | +1x |
- col_symbol_size = n_tot_ids[1] # for scaling the symbol sizes in forest plots+ x = ht_x[no_at_risk_tbl], |
|
| 408 | -+ | ||||
| 662 | +1x |
- )+ units = ht_units[no_at_risk_tbl] |
|||
| 409 | +663 |
- }+ ) |
|||
| 410 | +664 |
-
+ ) |
|||
| 411 | +665 |
- #' Labels for column variables in survival duration by subgroup table+ } |
|||
| 412 | +666 |
- #'+ |
|||
| 413 | +667 |
- #' @description `r lifecycle::badge("stable")`
+ #' Helper function to create patient-at-risk grobs |
|||
| 414 | +668 |
#' |
|||
| 415 | +669 |
- #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels.+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 416 | +670 |
#' |
|||
| 417 | +671 |
- #' @inheritParams tabulate_survival_subgroups+ #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of |
|||
| 418 | +672 |
- #' @inheritParams argument_convention+ #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is |
|||
| 419 | +673 |
- #' @param method (`string`)\cr p-value method for testing hazard ratio = 1.+ #' also obtained. |
|||
| 420 | +674 |
#' |
|||
| 421 | +675 |
- #' @return A `list` of variables and their labels to tabulate.+ #' @inheritParams g_km |
|||
| 422 | +676 |
- #'+ #' @inheritParams h_ggkm |
|||
| 423 | +677 |
- #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`.+ #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which |
|||
| 424 | +678 |
- #'+ #' includes the number of patients at risk at given time points. |
|||
| 425 | +679 |
- #' @export+ #' @param xlim (`numeric(1)`)\cr the maximum value on the x-axis (used to ensure the at risk table aligns with the KM |
|||
| 426 | +680 |
- d_survival_subgroups_colvars <- function(vars,+ #' graph). |
|||
| 427 | +681 |
- conf_level,+ #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
|||
| 428 | +682 |
- method,+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
|||
| 429 | +683 |
- time_unit = NULL) {
- |
- |||
| 430 | -21x | -
- checkmate::assert_character(vars)- |
- |||
| 431 | -21x | -
- checkmate::assert_string(time_unit, null.ok = TRUE)- |
- |||
| 432 | -21x | -
- checkmate::assert_subset(c("hr", "ci"), vars)
- |
- |||
| 433 | -21x | -
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
- |
- |||
| 434 | -21x | -
- checkmate::assert_subset(- |
- |||
| 435 | -21x | -
- vars,- |
- |||
| 436 | -21x | -
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ #' |
|||
| 437 | +684 |
- )+ #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three |
|||
| 438 | +685 | - - | -|||
| 439 | -21x | -
- propcase_time_label <- if (!is.null(time_unit)) {
- |
- |||
| 440 | -20x | -
- paste0("Median (", time_unit, ")")
+ #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`. |
|||
| 441 | +686 |
- } else {
- |
- |||
| 442 | -1x | -
- "Median"+ #' |
|||
| 443 | +687 |
- }+ #' @examples |
|||
| 444 | +688 | - - | -|||
| 445 | -21x | -
- varlabels <- c(- |
- |||
| 446 | -21x | -
- n = "n",- |
- |||
| 447 | -21x | -
- n_events = "Events",- |
- |||
| 448 | -21x | -
- median = propcase_time_label,- |
- |||
| 449 | -21x | -
- n_tot = "Total n",- |
- |||
| 450 | -21x | -
- n_tot_events = "Total Events",- |
- |||
| 451 | -21x | -
- hr = "Hazard Ratio",- |
- |||
| 452 | -21x | -
- ci = paste0(100 * conf_level, "% Wald CI"),- |
- |||
| 453 | -21x | -
- pval = method+ #' \donttest{
|
|||
| 454 | +689 |
- )+ #' library(dplyr) |
|||
| 455 | +690 | - - | -|||
| 456 | -21x | -
- colvars <- vars+ #' library(survival) |
|||
| 457 | +691 |
-
+ #' library(grid) |
|||
| 458 | +692 |
- # The `lcl` variable is just a placeholder available in the analysis data,+ #' |
|||
| 459 | +693 |
- # it is not acutally used in the tabulation.+ #' fit_km <- tern_ex_adtte %>% |
|||
| 460 | +694 |
- # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.- |
- |||
| 461 | -21x | -
- colvars[colvars == "ci"] <- "lcl"+ #' filter(PARAMCD == "OS") %>% |
|||
| 462 | +695 | - - | -|||
| 463 | -21x | -
- list(- |
- |||
| 464 | -21x | -
- vars = colvars,- |
- |||
| 465 | -21x | -
- labels = varlabels[vars]+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 466 | +696 |
- )+ #' |
|||
| 467 | +697 |
- }+ #' data_plot <- h_data_plot(fit_km = fit_km) |
| 1 | +698 |
- #' Helper functions for tabulating binary response by subgroup+ #' |
||
| 2 | +699 |
- #'+ #' xticks <- h_xticks(data = data_plot) |
||
| 3 | +700 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 | +701 |
- #'+ #' gg <- h_ggkm( |
||
| 5 | +702 |
- #' Helper functions that tabulate in a data frame statistics such as response rate+ #' data = data_plot, |
||
| 6 | +703 |
- #' and odds ratio for population subgroups.+ #' censor_show = TRUE, |
||
| 7 | +704 |
- #'+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 8 | +705 |
- #' @inheritParams argument_convention+ #' title = "tt", footnotes = "ff", yval = "Survival" |
||
| 9 | +706 |
- #' @inheritParams response_subgroups+ #' ) |
||
| 10 | +707 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' |
||
| 11 | +708 |
- #'+ #' # The annotation table reports the patient at risk for a given strata and |
||
| 12 | +709 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' # times (`xticks`). |
||
| 13 | +710 |
- #'+ #' annot_tbl <- summary(fit_km, times = xticks) |
||
| 14 | +711 |
- #' @examples+ #' if (is.null(fit_km$strata)) {
|
||
| 15 | +712 |
- #' library(dplyr)+ #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All")) |
||
| 16 | +713 |
- #' library(forcats)+ #' } else {
|
||
| 17 | +714 |
- #'+ #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
||
| 18 | +715 |
- #' adrs <- tern_ex_adrs+ #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 19 | +716 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' annot_tbl <- data.frame( |
||
| 20 | +717 |
- #'+ #' n.risk = annot_tbl$n.risk, |
||
| 21 | +718 |
- #' adrs_f <- adrs %>%+ #' time = annot_tbl$time, |
||
| 22 | +719 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' strata = annot_tbl$strata |
||
| 23 | +720 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ #' ) |
||
| 24 | +721 |
- #' droplevels() %>%+ #' } |
||
| 25 | +722 |
- #' mutate(+ #' |
||
| 26 | +723 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ #' # The annotation table is transformed into a grob. |
||
| 27 | +724 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks)) |
||
| 28 | +725 |
- #' rsp = AVALC == "CR"+ #' |
||
| 29 | +726 |
- #' )+ #' # For the representation, the layout is estimated for which the decomposition |
||
| 30 | +727 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' # of the graphic element is necessary. |
||
| 31 | +728 |
- #'+ #' g_el <- h_decompose_gg(gg) |
||
| 32 | +729 |
- #' @name h_response_subgroups+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
||
| 33 | +730 |
- NULL+ #' |
||
| 34 | +731 |
-
+ #' grid::grid.newpage() |
||
| 35 | +732 |
- #' @describeIn h_response_subgroups Helper to prepare a data frame of binary responses by arm.+ #' pushViewport(viewport(layout = lyt, height = .95, width = .95)) |
||
| 36 | +733 |
- #'+ #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1)) |
||
| 37 | +734 |
- #' @return+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2)) |
||
| 38 | +735 |
- #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`.+ #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1)) |
||
| 39 | +736 |
- #'+ #' grid::grid.draw(tbl$at_risk) |
||
| 40 | +737 |
- #' @examples+ #' popViewport() |
||
| 41 | +738 |
- #' h_proportion_df(+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1)) |
||
| 42 | +739 |
- #' c(TRUE, FALSE, FALSE),+ #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1)) |
||
| 43 | +740 |
- #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
+ #' grid::grid.draw(tbl$label) |
||
| 44 | +741 |
- #' )+ #' } |
||
| 45 | +742 |
#' |
||
| 46 | +743 |
#' @export |
||
| 47 | +744 |
- h_proportion_df <- function(rsp, arm) {
- |
- ||
| 48 | -79x | -
- checkmate::assert_logical(rsp)+ h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
|
||
| 49 | -78x | +745 | +1x |
- assert_valid_factor(arm, len = length(rsp))+ lifecycle::deprecate_warn( |
| 50 | -78x | +746 | +1x |
- non_missing_rsp <- !is.na(rsp)+ "0.9.4", |
| 51 | -78x | +747 | +1x |
- rsp <- rsp[non_missing_rsp]+ "h_grob_tbl_at_risk()", |
| 52 | -78x | +748 | +1x |
- arm <- arm[non_missing_rsp]+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 53 | +749 |
-
+ ) |
||
| 54 | -78x | +750 | +1x |
- lst_rsp <- split(rsp, arm)+ txtlines <- levels(as.factor(data$strata)) |
| 55 | -78x | +751 | +1x |
- lst_results <- Map(function(x, arm) {
+ nlines <- nlevels(as.factor(data$strata)) |
| 56 | -156x | +752 | +1x |
- if (length(x) > 0) {
+ y_int <- annot_tbl$time[2] - annot_tbl$time[1] |
| 57 | -154x | +753 | +1x |
- s_prop <- s_proportion(df = x)+ annot_tbl <- expand.grid( |
| 58 | -154x | +754 | +1x |
- data.frame(+ time = seq(0, xlim, y_int), |
| 59 | -154x | +755 | +1x |
- arm = arm,+ strata = unique(annot_tbl$strata) |
| 60 | -154x | +756 | +1x |
- n = length(x),+ ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
|
| 61 | -154x | +757 | +1x |
- n_rsp = unname(s_prop$n_prop[1]),+ annot_tbl[is.na(annot_tbl)] <- 0 |
| 62 | -154x | +758 | +1x |
- prop = unname(s_prop$n_prop[2]),+ y_str_unit <- as.numeric(annot_tbl$strata) |
| 63 | -154x | -
- stringsAsFactors = FALSE- |
- ||
| 64 | -+ | 759 | +1x |
- )+ vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines")) |
| 65 | -+ | |||
| 760 | +1x |
- } else {
+ if (title) {
|
||
| 66 | -2x | +761 | +1x |
- data.frame(+ gb_table_title <- grid::gList( |
| 67 | -2x | +762 | +1x |
- arm = arm,+ grid::textGrob( |
| 68 | -2x | +763 | +1x |
- n = 0L,+ label = "Patients at Risk:", |
| 69 | -2x | +764 | +1x |
- n_rsp = NA,+ x = 1, |
| 70 | -2x | +765 | +1x |
- prop = NA,+ y = grid::unit(0.2, "native"), |
| 71 | -2x | +766 | +1x |
- stringsAsFactors = FALSE+ gp = grid::gpar(fontface = "bold", fontsize = 10) |
| 72 | +767 |
) |
||
| 73 | +768 |
- }- |
- ||
| 74 | -78x | -
- }, lst_rsp, names(lst_rsp))+ ) |
||
| 75 | +769 |
-
+ } |
||
| 76 | -78x | +770 | +1x |
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ gb_table_left_annot <- grid::gList( |
| 77 | -78x | +771 | +1x |
- df$arm <- factor(df$arm, levels = levels(arm))+ grid::rectGrob( |
| 78 | -78x | +772 | +1x |
- df+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
| 79 | -+ | |||
| 773 | +1x |
- }+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
|
||
| 80 | -+ | |||
| 774 | +1x |
-
+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
||
| 81 | +775 |
- #' @describeIn h_response_subgroups Summarizes proportion of binary responses by arm and across subgroups+ ), |
||
| 82 | -+ | |||
| 776 | +1x |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ grid::textGrob( |
||
| 83 | -+ | |||
| 777 | +1x |
- #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ label = unique(annot_tbl$strata), |
||
| 84 | -+ | |||
| 778 | +1x |
- #' groupings for `subgroups` variables.+ x = 0.5, |
||
| 85 | -+ | |||
| 779 | +1x |
- #'+ y = grid::unit( |
||
| 86 | -+ | |||
| 780 | +1x |
- #' @return+ (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75, |
||
| 87 | -+ | |||
| 781 | +1x |
- #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`,+ "native" |
||
| 88 | +782 |
- #' `var`, `var_label`, and `row_type`.+ ), |
||
| 89 | -+ | |||
| 783 | +1x |
- #'+ gp = grid::gpar(fontface = "italic", fontsize = 10) |
||
| 90 | +784 |
- #' @examples+ ) |
||
| 91 | +785 |
- #' h_proportion_subgroups_df(+ ) |
||
| 92 | -+ | |||
| 786 | +1x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ gb_patient_at_risk <- grid::gList( |
||
| 93 | -+ | |||
| 787 | +1x |
- #' data = adrs_f+ grid::rectGrob( |
||
| 94 | -+ | |||
| 788 | +1x |
- #' )+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
||
| 95 | -+ | |||
| 789 | +1x |
- #'+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
|
||
| 96 | -+ | |||
| 790 | +1x |
- #' # Define groupings for BMRKR2 levels.+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
||
| 97 | +791 |
- #' h_proportion_subgroups_df(+ ), |
||
| 98 | -+ | |||
| 792 | +1x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ grid::textGrob( |
||
| 99 | -+ | |||
| 793 | +1x |
- #' data = adrs_f,+ label = annot_tbl$n.risk, |
||
| 100 | -+ | |||
| 794 | +1x |
- #' groups_lists = list(+ x = grid::unit(annot_tbl$time, "native"), |
||
| 101 | -+ | |||
| 795 | +1x |
- #' BMRKR2 = list(+ y = grid::unit( |
||
| 102 | -+ | |||
| 796 | +1x |
- #' "low" = "LOW",+ (max(y_str_unit) - y_str_unit) + .5, |
||
| 103 | -+ | |||
| 797 | +1x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ "line" |
||
| 104 | -+ | |||
| 798 | +1x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ ) # maybe native |
||
| 105 | +799 |
- #' )+ ) |
||
| 106 | +800 |
- #' )+ ) |
||
| 107 | +801 |
- #' )+ |
||
| 108 | -+ | |||
| 802 | +1x |
- #'+ ret <- list( |
||
| 109 | -+ | |||
| 803 | +1x |
- #' @export+ at_risk = grid::gList( |
||
| 110 | -+ | |||
| 804 | +1x |
- h_proportion_subgroups_df <- function(variables,+ grid::gTree( |
||
| 111 | -+ | |||
| 805 | +1x |
- data,+ vp = vp_table, |
||
| 112 | -+ | |||
| 806 | +1x |
- groups_lists = list(),+ children = grid::gList( |
||
| 113 | -+ | |||
| 807 | +1x |
- label_all = "All Patients") {
+ grid::gTree( |
||
| 114 | -17x | +808 | +1x |
- checkmate::assert_character(variables$rsp)+ vp = grid::dataViewport( |
| 115 | -17x | +809 | +1x |
- checkmate::assert_character(variables$arm)+ xscale = c(0, xlim) + c(-0.05, 0.05) * xlim, |
| 116 | -17x | +810 | +1x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ yscale = c(0, nlines + 1), |
| 117 | -17x | +811 | +1x |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ extension = c(0.05, 0) |
| 118 | -17x | +|||
| 812 | +
- assert_df_with_variables(data, variables)+ ), |
|||
| 119 | -17x | +813 | +1x |
- checkmate::assert_string(label_all)+ children = grid::gList(gb_patient_at_risk) |
| 120 | +814 |
-
+ ) |
||
| 121 | +815 |
- # Add All Patients.+ )+ |
+ ||
| 816 | ++ |
+ )+ |
+ ||
| 817 | ++ |
+ ), |
||
| 122 | -17x | +818 | +1x |
- result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])+ label = grid::gList( |
| 123 | -17x | +819 | +1x |
- result_all$subgroup <- label_all+ grid::gTree( |
| 124 | -17x | +820 | +1x |
- result_all$var <- "ALL"+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
| 125 | -17x | +821 | +1x |
- result_all$var_label <- label_all+ children = grid::gList( |
| 126 | -17x | +822 | +1x |
- result_all$row_type <- "content"+ grid::gTree(+ |
+
| 823 | +1x | +
+ vp = grid::dataViewport(+ |
+ ||
| 824 | +1x | +
+ xscale = 0:1,+ |
+ ||
| 825 | +1x | +
+ yscale = c(0, nlines + 1),+ |
+ ||
| 826 | +1x | +
+ extension = c(0.0, 0) |
||
| 127 | +827 |
-
+ ),+ |
+ ||
| 828 | +1x | +
+ children = grid::gList(gb_table_left_annot) |
||
| 128 | +829 |
- # Add Subgroups.+ ) |
||
| 129 | -17x | +|||
| 830 | +
- if (is.null(variables$subgroups)) {
+ ) |
|||
| 130 | -3x | +|||
| 831 | +
- result_all+ ) |
|||
| 131 | +832 |
- } else {
+ ) |
||
| 132 | -14x | +|||
| 833 | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ ) |
|||
| 133 | +834 | |||
| 134 | -14x | +835 | +1x |
- l_result <- lapply(l_data, function(grp) {
+ if (title) {
|
| 135 | -58x | +836 | +1x |
- result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])+ ret[["title"]] <- grid::gList( |
| 136 | -58x | +837 | +1x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ grid::gTree( |
| 137 | -58x | +838 | +1x |
- cbind(result, result_labels)+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
| 138 | -+ | |||
| 839 | +1x |
- })+ children = grid::gList( |
||
| 139 | -14x | +840 | +1x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ grid::gTree( |
| 140 | -14x | +841 | +1x |
- result_subgroups$row_type <- "analysis"+ vp = grid::dataViewport( |
| 141 | -+ | |||
| 842 | +1x |
-
+ xscale = 0:1, |
||
| 142 | -14x | +843 | +1x |
- rbind(+ yscale = c(0, 1), |
| 143 | -14x | +844 | +1x |
- result_all,+ extension = c(0, 0)+ |
+
| 845 | ++ |
+ ), |
||
| 144 | -14x | +846 | +1x |
- result_subgroups+ children = grid::gList(gb_table_title) |
| 145 | +847 |
- )+ ) |
||
| 146 | +848 |
- }+ ) |
||
| 147 | +849 |
- }+ ) |
||
| 148 | +850 |
-
+ ) |
||
| 149 | +851 |
- #' @describeIn h_response_subgroups Helper to prepare a data frame with estimates of+ } |
||
| 150 | +852 |
- #' the odds ratio between a treatment and a control arm.+ + |
+ ||
| 853 | +1x | +
+ ret |
||
| 151 | +854 |
- #'+ } |
||
| 152 | +855 |
- #' @inheritParams response_subgroups+ |
||
| 153 | +856 |
- #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed.+ #' Helper function to create survival estimation grobs |
||
| 154 | +857 |
#' |
||
| 155 | +858 |
- #' @return+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 156 | +859 |
- #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and+ #' |
||
| 157 | +860 |
- #' optionally `pval` and `pval_label`.+ #' The survival fit is transformed in a grob containing a table with groups in |
||
| 158 | +861 |
- #'+ #' rows characterized by N, median and 95% confidence interval. |
||
| 159 | +862 |
- #' @examples+ #' |
||
| 160 | +863 |
- #' # Unstratatified analysis.+ #' @inheritParams g_km |
||
| 161 | +864 |
- #' h_odds_ratio_df(+ #' @inheritParams h_data_plot |
||
| 162 | +865 |
- #' c(TRUE, FALSE, FALSE, TRUE),+ #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()]. |
||
| 163 | +866 |
- #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location. |
||
| 164 | +867 |
- #' )+ #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location. |
||
| 165 | +868 |
- #'+ #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob. |
||
| 166 | +869 |
- #' # Include p-value.+ #' |
||
| 167 | +870 |
- #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")+ #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
||
| 168 | +871 |
#' |
||
| 169 | +872 |
- #' # Stratatified analysis.+ #' @examples |
||
| 170 | +873 |
- #' h_odds_ratio_df(+ #' \donttest{
|
||
| 171 | +874 |
- #' rsp = adrs_f$rsp,+ #' library(dplyr) |
||
| 172 | +875 |
- #' arm = adrs_f$ARM,+ #' library(survival) |
||
| 173 | +876 |
- #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
+ #' library(grid) |
||
| 174 | +877 |
- #' method = "cmh"+ #' |
||
| 175 | +878 |
- #' )+ #' grid::grid.newpage() |
||
| 176 | +879 |
- #'+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
||
| 177 | +880 |
- #' @export+ #' tern_ex_adtte %>% |
||
| 178 | +881 |
- h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
- |
- ||
| 179 | -84x | -
- assert_valid_factor(arm, n.levels = 2, len = length(rsp))+ #' filter(PARAMCD == "OS") %>% |
||
| 180 | +882 |
-
+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 181 | -84x | +|||
| 883 | +
- df_rsp <- data.frame(+ #' h_grob_median_surv() %>% |
|||
| 182 | -84x | +|||
| 884 | +
- rsp = rsp,+ #' grid::grid.draw() |
|||
| 183 | -84x | +|||
| 885 | +
- arm = arm+ #' } |
|||
| 184 | +886 |
- )+ #' |
||
| 185 | +887 |
-
+ #' @export |
||
| 186 | -84x | +|||
| 888 | +
- if (!is.null(strata_data)) {
+ h_grob_median_surv <- function(fit_km, |
|||
| 187 | -11x | +|||
| 889 | +
- strata_var <- interaction(strata_data, drop = TRUE)+ armval = "All", |
|||
| 188 | -11x | +|||
| 890 | +
- strata_name <- "strata"+ x = 0.9, |
|||
| 189 | +891 |
-
+ y = 0.9, |
||
| 190 | -11x | +|||
| 892 | +
- assert_valid_factor(strata_var, len = nrow(df_rsp))+ width = grid::unit(0.3, "npc"), |
|||
| 191 | +893 |
-
+ ttheme = gridExtra::ttheme_default()) {
|
||
| 192 | -11x | +894 | +1x |
- df_rsp[[strata_name]] <- strata_var+ lifecycle::deprecate_warn( |
| 193 | -+ | |||
| 895 | +1x |
- } else {
+ "0.9.4", |
||
| 194 | -73x | +896 | +1x |
- strata_name <- NULL+ "h_grob_median_surv()", |
| 195 | -+ | |||
| 897 | +1x |
- }+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 196 | +898 |
-
+ ) |
||
| 197 | -84x | +899 | +1x |
- l_df <- split(df_rsp, arm)+ data <- h_tbl_median_surv(fit_km, armval = armval) |
| 198 | +900 | |||
| 199 | -84x | +901 | +1x |
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ |
+
| 902 | +1x | +
+ height <- width * (nrow(data) + 1) / 12 |
||
| 200 | +903 |
- # Odds ratio and CI.+ |
||
| 201 | -82x | +904 | +1x |
- result_odds_ratio <- s_odds_ratio(+ w <- paste(" ", c(
|
| 202 | -82x | +905 | +1x |
- df = l_df[[2]],+ rownames(data)[which.max(nchar(rownames(data)))], |
| 203 | -82x | +906 | +1x |
- .var = "rsp",+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
| 204 | -82x | +|||
| 907 | +
- .ref_group = l_df[[1]],+ )) |
|||
| 205 | -82x | +908 | +1x |
- .in_ref_col = FALSE,+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
| 206 | -82x | +|||
| 909 | +
- .df_row = df_rsp,+ |
|||
| 207 | -82x | +910 | +1x |
- variables = list(arm = "arm", strata = strata_name),+ w_txt <- sapply(1:64, function(x) {
|
| 208 | -82x | +911 | +64x |
- conf_level = conf_level+ graphics::par(ps = x) |
| 209 | -+ | |||
| 912 | +64x |
- )+ graphics::strwidth(w[4], units = "in") |
||
| 210 | +913 |
-
+ }) |
||
| 211 | -82x | +914 | +1x |
- df <- data.frame(+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
| 212 | +915 |
- # Dummy column needed downstream to create a nested header.+ |
||
| 213 | -82x | +916 | +1x |
- arm = " ",+ h_txt <- sapply(1:64, function(x) {
|
| 214 | -82x | +917 | +64x |
- n_tot = unname(result_odds_ratio$n_tot["n_tot"]),+ graphics::par(ps = x) |
| 215 | -82x | +918 | +64x |
- or = unname(result_odds_ratio$or_ci["est"]),+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
| 216 | -82x | +|||
| 919 | +
- lcl = unname(result_odds_ratio$or_ci["lcl"]),+ }) |
|||
| 217 | -82x | +920 | +1x |
- ucl = unname(result_odds_ratio$or_ci["ucl"]),+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
| 218 | -82x | +|||
| 921 | +
- conf_level = conf_level,+ |
|||
| 219 | -82x | +922 | +1x |
- stringsAsFactors = FALSE+ if (ttheme$core$fg_params$fontsize == 12) {
|
| 220 | -+ | |||
| 923 | +1x |
- )+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 221 | -+ | |||
| 924 | +1x |
-
+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 222 | -82x | +925 | +1x |
- if (!is.null(method)) {
+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 223 | +926 |
- # Test for difference.+ } |
||
| 224 | -44x | +|||
| 927 | +
- result_test <- s_test_proportion_diff(+ |
|||
| 225 | -44x | +928 | +1x |
- df = l_df[[2]],+ gt <- gridExtra::tableGrob( |
| 226 | -44x | +929 | +1x |
- .var = "rsp",+ d = data, |
| 227 | -44x | +930 | +1x |
- .ref_group = l_df[[1]],+ theme = ttheme |
| 228 | -44x | +|||
| 931 | +
- .in_ref_col = FALSE,+ ) |
|||
| 229 | -44x | +932 | +1x |
- variables = list(strata = strata_name),+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
| 230 | -44x | +933 | +1x |
- method = method+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
| 231 | +934 |
- )+ |
||
| 232 | -+ | |||
| 935 | +1x |
-
+ vp <- grid::viewport( |
||
| 233 | -44x | +936 | +1x |
- df$pval <- as.numeric(result_test$pval)+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
| 234 | -44x | +937 | +1x |
- df$pval_label <- obj_label(result_test$pval)+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
| 235 | -+ | |||
| 938 | +1x |
- }+ height = height, |
||
| 236 | -+ | |||
| 939 | +1x |
-
+ width = width,+ |
+ ||
| 940 | +1x | +
+ just = c("right", "top")
|
||
| 237 | +941 |
- # In those cases cannot go through the model so will obtain n_tot from data.+ ) |
||
| 238 | +942 |
- } else if (+ |
||
| 239 | -2x | +943 | +1x |
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ grid::gList( |
| 240 | -2x | +944 | +1x |
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ grid::gTree( |
| 241 | -+ | |||
| 945 | +1x |
- ) {
+ vp = vp, |
||
| 242 | -2x | +946 | +1x |
- df <- data.frame(+ children = grid::gList(gt) |
| 243 | +947 |
- # Dummy column needed downstream to create a nested header.- |
- ||
| 244 | -2x | -
- arm = " ",+ ) |
||
| 245 | -2x | +|||
| 948 | +
- n_tot = sum(stats::complete.cases(df_rsp)),+ ) |
|||
| 246 | -2x | +|||
| 949 | +
- or = NA,+ } |
|||
| 247 | -2x | +|||
| 950 | +
- lcl = NA,+ |
|||
| 248 | -2x | +|||
| 951 | +
- ucl = NA,+ #' Helper function to create grid object with y-axis annotation |
|||
| 249 | -2x | +|||
| 952 | +
- conf_level = conf_level,+ #' |
|||
| 250 | -2x | +|||
| 953 | +
- stringsAsFactors = FALSE+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 251 | +954 |
- )+ #' |
||
| 252 | -2x | +|||
| 955 | +
- if (!is.null(method)) {
+ #' Build the y-axis annotation from a decomposed `ggplot`. |
|||
| 253 | -2x | +|||
| 956 | +
- df$pval <- NA+ #' |
|||
| 254 | -2x | +|||
| 957 | +
- df$pval_label <- NA+ #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`. |
|||
| 255 | +958 |
- }+ #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`. |
||
| 256 | +959 |
- } else {
+ #' |
||
| 257 | -! | +|||
| 960 | +
- df <- data.frame(+ #' @return A `gTree` object containing the y-axis annotation from a `ggplot`. |
|||
| 258 | +961 |
- # Dummy column needed downstream to create a nested header.+ #' |
||
| 259 | -! | +|||
| 962 | +
- arm = " ",+ #' @examples |
|||
| 260 | -! | +|||
| 963 | +
- n_tot = 0L,+ #' \donttest{
|
|||
| 261 | -! | +|||
| 964 | +
- or = NA,+ #' library(dplyr) |
|||
| 262 | -! | +|||
| 965 | +
- lcl = NA,+ #' library(survival) |
|||
| 263 | -! | +|||
| 966 | +
- ucl = NA,+ #' library(grid) |
|||
| 264 | -! | +|||
| 967 | +
- conf_level = conf_level,+ #' |
|||
| 265 | -! | +|||
| 968 | +
- stringsAsFactors = FALSE+ #' fit_km <- tern_ex_adtte %>% |
|||
| 266 | +969 |
- )+ #' filter(PARAMCD == "OS") %>% |
||
| 267 | +970 |
-
+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 268 | -! | +|||
| 971 | +
- if (!is.null(method)) {
+ #' data_plot <- h_data_plot(fit_km = fit_km) |
|||
| 269 | -! | +|||
| 972 | +
- df$pval <- NA+ #' xticks <- h_xticks(data = data_plot) |
|||
| 270 | -! | +|||
| 973 | +
- df$pval_label <- NA+ #' gg <- h_ggkm( |
|||
| 271 | +974 |
- }+ #' data = data_plot, |
||
| 272 | +975 |
- }+ #' censor_show = TRUE, |
||
| 273 | +976 |
-
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 274 | -84x | +|||
| 977 | +
- df+ #' title = "title", footnotes = "footnotes", yval = "Survival" |
|||
| 275 | +978 |
- }+ #' ) |
||
| 276 | +979 |
-
+ #' |
||
| 277 | +980 |
- #' @describeIn h_response_subgroups Summarizes estimates of the odds ratio between a treatment and a control+ #' g_el <- h_decompose_gg(gg) |
||
| 278 | +981 |
- #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in+ #' |
||
| 279 | +982 |
- #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`+ #' grid::grid.newpage() |
||
| 280 | +983 |
- #' and `strata`. `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20)) |
||
| 281 | +984 |
- #'+ #' pushViewport(pvp) |
||
| 282 | +985 |
- #' @return+ #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)) |
||
| 283 | +986 |
- #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`,+ #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA)) |
||
| 284 | +987 |
- #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`.+ #' } |
||
| 285 | +988 |
#' |
||
| 286 | +989 |
- #' @examples+ #' @export |
||
| 287 | +990 |
- #' # Unstratified analysis.+ h_grob_y_annot <- function(ylab, yaxis) {
|
||
| 288 | -+ | |||
| 991 | +1x |
- #' h_odds_ratio_subgroups_df(+ lifecycle::deprecate_warn(+ |
+ ||
| 992 | +1x | +
+ "0.9.4",+ |
+ ||
| 993 | +1x | +
+ "h_grob_y_annot()",+ |
+ ||
| 994 | +1x | +
+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 289 | +995 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ )+ |
+ ||
| 996 | +1x | +
+ grid::gList(+ |
+ ||
| 997 | +1x | +
+ grid::gTree(+ |
+ ||
| 998 | +1x | +
+ vp = grid::viewport(+ |
+ ||
| 999 | +1x | +
+ width = grid::convertX(yaxis$widths + ylab$widths, "pt"),+ |
+ ||
| 1000 | +1x | +
+ x = grid::unit(1, "npc"),+ |
+ ||
| 1001 | +1x | +
+ just = "right" |
||
| 290 | +1002 |
- #' data = adrs_f+ ),+ |
+ ||
| 1003 | +1x | +
+ children = grid::gList(cbind(ylab, yaxis)) |
||
| 291 | +1004 |
- #' )+ ) |
||
| 292 | +1005 |
- #'+ ) |
||
| 293 | +1006 |
- #' # Stratified analysis.+ } |
||
| 294 | +1007 |
- #' h_odds_ratio_subgroups_df(+ |
||
| 295 | +1008 |
- #' variables = list(+ #' Helper function to create Cox-PH grobs |
||
| 296 | +1009 |
- #' rsp = "rsp",+ #' |
||
| 297 | +1010 |
- #' arm = "ARM",+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 298 | +1011 |
- #' subgroups = c("SEX", "BMRKR2"),
+ #' |
||
| 299 | +1012 |
- #' strata = c("STRATA1", "STRATA2")
+ #' Grob of `rtable` output from [h_tbl_coxph_pairwise()] |
||
| 300 | +1013 |
- #' ),+ #' |
||
| 301 | +1014 |
- #' data = adrs_f+ #' @inheritParams h_grob_median_surv |
||
| 302 | +1015 |
- #' )+ #' @param ... arguments to pass to [h_tbl_coxph_pairwise()]. |
||
| 303 | +1016 |
- #'+ #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location. |
||
| 304 | +1017 |
- #' # Define groupings of BMRKR2 levels.+ #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location. |
||
| 305 | +1018 |
- #' h_odds_ratio_subgroups_df(+ #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob. |
||
| 306 | +1019 |
- #' variables = list(+ #' |
||
| 307 | +1020 |
- #' rsp = "rsp",+ #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
||
| 308 | +1021 |
- #' arm = "ARM",+ #' and `p-value (log-rank)`. |
||
| 309 | +1022 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' |
||
| 310 | +1023 |
- #' ),+ #' @examples |
||
| 311 | +1024 |
- #' data = adrs_f,+ #' \donttest{
|
||
| 312 | +1025 |
- #' groups_lists = list(+ #' library(dplyr) |
||
| 313 | +1026 |
- #' BMRKR2 = list(+ #' library(survival) |
||
| 314 | +1027 |
- #' "low" = "LOW",+ #' library(grid) |
||
| 315 | +1028 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' |
||
| 316 | +1029 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' grid::grid.newpage() |
||
| 317 | +1030 |
- #' )+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
||
| 318 | +1031 |
- #' )+ #' data <- tern_ex_adtte %>% |
||
| 319 | +1032 |
- #' )+ #' filter(PARAMCD == "OS") %>% |
||
| 320 | +1033 |
- #'+ #' mutate(is_event = CNSR == 0) |
||
| 321 | +1034 |
- #' @export+ #' tbl_grob <- h_grob_coxph( |
||
| 322 | +1035 |
- h_odds_ratio_subgroups_df <- function(variables,+ #' df = data, |
||
| 323 | +1036 |
- data,+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"), |
||
| 324 | +1037 |
- groups_lists = list(),+ #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5 |
||
| 325 | +1038 |
- conf_level = 0.95,+ #' ) |
||
| 326 | +1039 |
- method = NULL,+ #' grid::grid.draw(tbl_grob) |
||
| 327 | +1040 |
- label_all = "All Patients") {
+ #' } |
||
| 328 | -18x | +|||
| 1041 | +
- if ("strat" %in% names(variables)) {
+ #' |
|||
| 329 | -! | +|||
| 1042 | +
- warning(+ #' @export |
|||
| 330 | -! | +|||
| 1043 | +
- "Warning: the `strat` element name of the `variables` list argument to `h_odds_ratio_subgroups_df() ",+ h_grob_coxph <- function(..., |
|||
| 331 | -! | +|||
| 1044 | +
- "was deprecated in tern 0.9.4.\n ",+ x = 0, |
|||
| 332 | -! | +|||
| 1045 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ y = 0, |
|||
| 333 | +1046 |
- )+ width = grid::unit(0.4, "npc"), |
||
| 334 | -! | +|||
| 1047 | +
- variables[["strata"]] <- variables[["strat"]]+ ttheme = gridExtra::ttheme_default( |
|||
| 335 | +1048 |
- }+ padding = grid::unit(c(1, .5), "lines"), |
||
| 336 | +1049 |
-
+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
|
||
| 337 | -18x | +|||
| 1050 | +
- checkmate::assert_character(variables$rsp)+ )) {
|
|||
| 338 | -18x | +1051 | +1x |
- checkmate::assert_character(variables$arm)+ lifecycle::deprecate_warn( |
| 339 | -18x | +1052 | +1x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ "0.9.4", |
| 340 | -18x | +1053 | +1x |
- checkmate::assert_character(variables$strata, null.ok = TRUE)+ "h_grob_coxph()", |
| 341 | -18x | +1054 | +1x |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 342 | -18x | +|||
| 1055 | +
- assert_df_with_variables(data, variables)+ ) |
|||
| 343 | -18x | +1056 | +1x |
- checkmate::assert_string(label_all)+ data <- h_tbl_coxph_pairwise(...) |
| 344 | +1057 | |||
| 345 | -18x | +1058 | +1x |
- strata_data <- if (is.null(variables$strata)) {
+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in") |
| 346 | -16x | +1059 | +1x |
- NULL+ height <- width * (nrow(data) + 1) / 12 |
| 347 | +1060 |
- } else {
+
|
||
| 348 | -2x | +1061 | +1x |
- data[, variables$strata, drop = FALSE]+ w <- paste(" ", c(
|
| 349 | -+ | |||
| 1062 | +1x |
- }+ rownames(data)[which.max(nchar(rownames(data)))], |
||
| 350 | -+ | |||
| 1063 | +1x |
-
+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
||
| 351 | +1064 |
- # Add All Patients.- |
- ||
| 352 | -18x | -
- result_all <- h_odds_ratio_df(+ )) |
||
| 353 | -18x | +1065 | +1x |
- rsp = data[[variables$rsp]],+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
| 354 | -18x | +|||
| 1066 | +
- arm = data[[variables$arm]],+ |
|||
| 355 | -18x | +1067 | +1x |
- strata_data = strata_data,+ w_txt <- sapply(1:64, function(x) {
|
| 356 | -18x | +1068 | +64x |
- conf_level = conf_level,+ graphics::par(ps = x) |
| 357 | -18x | +1069 | +64x |
- method = method+ graphics::strwidth(w[4], units = "in") |
| 358 | +1070 |
- )- |
- ||
| 359 | -18x | -
- result_all$subgroup <- label_all+ }) |
||
| 360 | -18x | +1071 | +1x |
- result_all$var <- "ALL"+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
| 361 | -18x | +|||
| 1072 | +
- result_all$var_label <- label_all+ |
|||
| 362 | -18x | -
- result_all$row_type <- "content"- |
- ||
| 363 | -+ | 1073 | +1x |
-
+ h_txt <- sapply(1:64, function(x) {
|
| 364 | -18x | +1074 | +64x |
- if (is.null(variables$subgroups)) {
+ graphics::par(ps = x) |
| 365 | -3x | +1075 | +64x |
- result_all+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
| 366 | +1076 |
- } else {
+ }) |
||
| 367 | -15x | +1077 | +1x |
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
| 368 | +1078 | |||
| 369 | -15x | +1079 | +1x |
- l_result <- lapply(l_data, function(grp) {
+ if (ttheme$core$fg_params$fontsize == 12) {
|
| 370 | -62x | +1080 | +1x |
- grp_strata_data <- if (is.null(variables$strata)) {
+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 371 | -54x | -
- NULL- |
- ||
| 372 | -+ | 1081 | +1x |
- } else {
+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 373 | -8x | +1082 | +1x |
- grp$df[, variables$strata, drop = FALSE]+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 374 | +1083 |
- }+ } |
||
| 375 | +1084 | |||
| 376 | -62x | +1085 | +1x |
- result <- h_odds_ratio_df(+ tryCatch( |
| 377 | -62x | +1086 | +1x |
- rsp = grp$df[[variables$rsp]],+ expr = {
|
| 378 | -62x | +1087 | +1x |
- arm = grp$df[[variables$arm]],+ gt <- gridExtra::tableGrob( |
| 379 | -62x | +1088 | +1x |
- strata_data = grp_strata_data,+ d = data, |
| 380 | -62x | +1089 | +1x |
- conf_level = conf_level,+ theme = ttheme |
| 381 | -62x | +1090 | +1x |
- method = method+ ) # ERROR 'data' must be of a vector type, was 'NULL' |
| 382 | -+ | |||
| 1091 | +1x |
- )+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
||
| 383 | -62x | +1092 | +1x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
| 384 | -62x | +1093 | +1x |
- cbind(result, result_labels)+ vp <- grid::viewport( |
| 385 | -+ | |||
| 1094 | +1x |
- })+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
||
| 386 | -+ | |||
| 1095 | +1x |
-
+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
||
| 387 | -15x | +1096 | +1x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ height = height, |
| 388 | -15x | +1097 | +1x |
- result_subgroups$row_type <- "analysis"+ width = width,+ |
+
| 1098 | +1x | +
+ just = c("left", "bottom")
|
||
| 389 | +1099 |
-
+ ) |
||
| 390 | -15x | +1100 | +1x |
- rbind(+ grid::gList( |
| 391 | -15x | +1101 | +1x |
- result_all,+ grid::gTree( |
| 392 | -15x | +1102 | +1x |
- result_subgroups+ vp = vp,+ |
+
| 1103 | +1x | +
+ children = grid::gList(gt) |
||
| 393 | +1104 |
- )+ ) |
||
| 394 | +1105 |
- }+ ) |
||
| 395 | +1106 |
- }+ },+ |
+ ||
| 1107 | +1x | +
+ error = function(w) {
+ |
+ ||
| 1108 | +! | +
+ message(paste(+ |
+ ||
| 1109 | +! | +
+ "Warning: Cox table will not be displayed as there is",+ |
+ ||
| 1110 | +! | +
+ "not any level to be compared in the arm variable."+ |
+ ||
| 1111 | ++ |
+ ))+ |
+ ||
| 1112 | +! | +
+ return(+ |
+ ||
| 1113 | +! | +
+ grid::gList(+ |
+ ||
| 1114 | +! | +
+ grid::gTree(+ |
+ ||
| 1115 | +! | +
+ vp = NULL,+ |
+ ||
| 1116 | +! | +
+ children = NULL+ |
+ ||
| 1117 | ++ |
+ )+ |
+ ||
| 1118 | ++ |
+ )+ |
+ ||
| 1119 | ++ |
+ )+ |
+ ||
| 1120 | ++ |
+ }+ |
+ ||
| 1121 | ++ |
+ )+ |
+ ||
| 1122 | ++ |
+ } |
| 1 |
- #' Helper functions for tabulating biomarker effects on binary response by subgroup+ # summarize_glm_count ---------------------------------------------------------- |
||
| 2 |
- #'+ #' Summarize Poisson negative binomial regression |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 |
- #'+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' Helper functions which are documented here separately to not confuse the user+ #' |
||
| 6 |
- #' when reading about the user-facing functions.+ #' Summarize results of a Poisson negative binomial regression. |
||
| 7 |
- #'+ #' This can be used to analyze count and/or frequency data using a linear model. |
||
| 8 |
- #' @inheritParams response_biomarkers_subgroups+ #' It is specifically useful for analyzing count data (using the Poisson or Negative |
||
| 9 |
- #' @inheritParams extract_rsp_biomarkers+ #' Binomial distribution) that is result of a generalized linear model of one (e.g. arm) or more |
||
| 10 |
- #' @inheritParams argument_convention+ #' covariates. |
||
| 12 |
- #' @examples+ #' @inheritParams h_glm_count |
||
| 13 |
- #' library(dplyr)+ #' @inheritParams argument_convention |
||
| 14 |
- #' library(forcats)+ #' @param rate_mean_method (`character(1)`)\cr method used to estimate the mean odds ratio. Defaults to `emmeans`. |
||
| 15 |
- #'+ #' see details for more information. |
||
| 16 |
- #' adrs <- tern_ex_adrs+ #' @param scale (`numeric(1)`)\cr linear scaling factor for rate and confidence intervals. Defaults to `1`. |
||
| 17 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 19 |
- #' adrs_f <- adrs %>%+ #' Options are: ``r shQuote(get_stats("summarize_glm_count"))``
|
||
| 20 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' |
||
| 21 |
- #' mutate(rsp = AVALC == "CR")+ #' @details |
||
| 22 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' `summarize_glm_count()` uses `s_glm_count()` to calculate the statistics for the table. This |
||
| 23 |
- #'+ #' analysis function uses [h_glm_count()] to estimate the GLM with [stats::glm()] for Poisson and Quasi-Poisson |
||
| 24 |
- #' @name h_response_biomarkers_subgroups+ #' distributions or [MASS::glm.nb()] for Negative Binomial distribution. All methods assume a |
||
| 25 |
- NULL+ #' logarithmic link function. |
||
| 26 |
-
+ #' |
||
| 27 |
- #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list+ #' At this point, rates and confidence intervals are estimated from the model using |
||
| 28 |
- #' to the "logistic regression" variable list. The reason is that currently there is an+ #' either [emmeans::emmeans()] when `rate_mean_method = "emmeans"` or [h_ppmeans()] |
||
| 29 |
- #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`.+ #' when `rate_mean_method = "ppmeans"`. |
||
| 31 |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ #' If a reference group is specified while building the table with `split_cols_by(ref_group)`, |
||
| 32 |
- #'+ #' no rate ratio or `p-value` are calculated. Otherwise, we use [emmeans::contrast()] to |
||
| 33 |
- #' @return+ #' calculate the rate ratio and `p-value` for the reference group. Values are always estimated |
||
| 34 |
- #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`.+ #' with `method = "trt.vs.ctrl"` and `ref` equal to the first `arm` value. |
||
| 36 |
- #' @examples+ #' @name summarize_glm_count |
||
| 37 |
- #' # This is how the variable list is converted internally.+ NULL |
||
| 38 |
- #' h_rsp_to_logistic_variables(+ |
||
| 39 |
- #' variables = list(+ #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments |
||
| 40 |
- #' rsp = "RSP",+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 41 |
- #' covariates = c("A", "B"),
+ #' |
||
| 42 |
- #' strata = "D"+ #' @return |
||
| 43 |
- #' ),+ #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions, |
||
| 44 |
- #' biomarker = "AGE"+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 45 |
- #' )+ #' the statistics from `s_glm_count()` to the table layout. |
||
| 47 |
- #' @export+ #' @examples |
||
| 48 |
- h_rsp_to_logistic_variables <- function(variables, biomarker) {
+ #' library(dplyr) |
||
| 49 | -49x | +
- if ("strat" %in% names(variables)) {
+ #' |
|
| 50 | -! | +
- warning(+ #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE") |
|
| 51 | -! | +
- "Warning: the `strat` element name of the `variables` list argument to `h_rsp_to_logistic_variables() ",+ #' anl$AVAL_f <- as.factor(anl$AVAL) |
|
| 52 | -! | +
- "was deprecated in tern 0.9.4.\n ",+ #' |
|
| 53 | -! | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' lyt <- basic_table() %>% |
|
| 54 |
- )+ #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
|
||
| 55 | -! | +
- variables[["strata"]] <- variables[["strat"]]+ #' add_colcounts() %>% |
|
| 56 |
- }+ #' analyze_vars( |
||
| 57 | -49x | +
- checkmate::assert_list(variables)+ #' "AVAL_f", |
|
| 58 | -49x | +
- checkmate::assert_string(variables$rsp)+ #' var_labels = "Number of exacerbations per patient", |
|
| 59 | -49x | +
- checkmate::assert_string(biomarker)+ #' .stats = c("count_fraction"),
|
|
| 60 | -49x | +
- list(+ #' .formats = c("count_fraction" = "xx (xx.xx%)"),
|
|
| 61 | -49x | +
- response = variables$rsp,+ #' .labels = c("Number of exacerbations per patient")
|
|
| 62 | -49x | +
- arm = biomarker,+ #' ) %>% |
|
| 63 | -49x | +
- covariates = variables$covariates,+ #' summarize_glm_count( |
|
| 64 | -49x | +
- strata = variables$strata+ #' vars = "AVAL", |
|
| 65 |
- )+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL), |
||
| 66 |
- }+ #' conf_level = 0.95, |
||
| 67 |
-
+ #' distribution = "poisson", |
||
| 68 |
- #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and+ #' rate_mean_method = "emmeans", |
||
| 69 |
- #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple+ #' var_labels = "Adjusted (P) exacerbation rate (per year)", |
||
| 70 |
- #' biomarkers in a given single data set.+ #' table_names = "adjP", |
||
| 71 |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ #' .stats = c("rate"),
|
||
| 72 |
- #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`+ #' .labels = c(rate = "Rate") |
||
| 73 |
- #' and `strata`.+ #' ) %>% |
||
| 74 |
- #'+ #' summarize_glm_count( |
||
| 75 |
- #' @return+ #' vars = "AVAL", |
||
| 76 |
- #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
|
||
| 77 |
- #'+ #' conf_level = 0.95, |
||
| 78 |
- #' @examples+ #' distribution = "quasipoisson", |
||
| 79 |
- #' # For a single population, estimate separately the effects+ #' rate_mean_method = "ppmeans", |
||
| 80 |
- #' # of two biomarkers.+ #' var_labels = "Adjusted (QP) exacerbation rate (per year)", |
||
| 81 |
- #' df <- h_logistic_mult_cont_df(+ #' table_names = "adjQP", |
||
| 82 |
- #' variables = list(+ #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 83 |
- #' rsp = "rsp",+ #' .labels = c( |
||
| 84 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio", |
||
| 85 |
- #' covariates = "SEX"+ #' rate_ratio_ci = "Rate Ratio CI", pval = "p value" |
||
| 86 |
- #' ),+ #' ) |
||
| 87 |
- #' data = adrs_f+ #' ) |
||
| 88 |
- #' )+ #' |
||
| 89 |
- #' df+ #' build_table(lyt = lyt, df = anl) |
||
| 91 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ #' @export |
||
| 92 |
- #' h_coxreg_mult_cont_df(+ summarize_glm_count <- function(lyt, |
||
| 93 |
- #' variables = list(+ vars, |
||
| 94 |
- #' rsp = "rsp",+ variables, |
||
| 95 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ distribution, |
||
| 96 |
- #' covariates = "SEX",+ conf_level, |
||
| 97 |
- #' strata = "STRATA1"+ rate_mean_method = c("emmeans", "ppmeans")[1],
|
||
| 98 |
- #' ),+ weights = stats::weights, |
||
| 99 |
- #' data = adrs_f[NULL, ]+ scale = 1, |
||
| 100 |
- #' )+ var_labels, |
||
| 101 |
- #'+ na_str = default_na_str(), |
||
| 102 |
- #' @export+ nested = TRUE, |
||
| 103 |
- h_logistic_mult_cont_df <- function(variables,+ ..., |
||
| 104 |
- data,+ show_labels = "visible", |
||
| 105 |
- control = control_logistic()) {
+ table_names = vars, |
||
| 106 | -28x | +
- if ("strat" %in% names(variables)) {
+ .stats = get_stats("summarize_glm_count"),
|
|
| 107 | -! | +
- warning(+ .formats = NULL, |
|
| 108 | -! | +
- "Warning: the `strat` element name of the `variables` list argument to `h_logistic_mult_cont_df() ",+ .labels = NULL, |
|
| 109 | -! | +
- "was deprecated in tern 0.9.4.\n ",+ .indent_mods = c( |
|
| 110 | -! | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ "n" = 0L, |
|
| 111 |
- )+ "rate" = 0L, |
||
| 112 | -! | +
- variables[["strata"]] <- variables[["strat"]]+ "rate_ci" = 1L, |
|
| 113 |
- }+ "rate_ratio" = 0L, |
||
| 114 | -28x | +
- assert_df_with_variables(data, variables)+ "rate_ratio_ci" = 1L, |
|
| 115 |
-
+ "pval" = 1L |
||
| 116 | -28x | +
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ )) {
|
|
| 117 | -28x | +3x |
- checkmate::assert_list(control, names = "named")+ checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans"))
|
| 119 | -28x | +3x |
- conf_level <- control[["conf_level"]]+ extra_args <- list( |
| 120 | -28x | +3x |
- pval_label <- "p-value (Wald)"+ variables = variables, distribution = distribution, conf_level = conf_level, |
| 121 | -+ | 3x |
-
+ rate_mean_method = rate_mean_method, weights = weights, scale = scale, ... |
| 122 |
- # If there is any data, run model, otherwise return empty results.+ ) |
||
| 123 | -28x | +
- if (nrow(data) > 0) {
+
|
|
| 124 | -27x | +
- bm_cols <- match(variables$biomarkers, names(data))+ # Selecting parameters following the statistics |
|
| 125 | -27x | +3x |
- l_result <- lapply(variables$biomarkers, function(bm) {
+ .formats <- get_formats_from_stats(.stats, formats_in = .formats) |
| 126 | -48x | +3x |
- model_fit <- fit_logistic(+ .labels <- get_labels_from_stats(.stats, labels_in = .labels) |
| 127 | -48x | +3x |
- variables = h_rsp_to_logistic_variables(variables, bm),+ .indent_mods <- get_indents_from_stats(.stats, indents_in = .indent_mods) |
| 128 | -48x | +
- data = data,+ |
|
| 129 | -48x | +3x |
- response_definition = control$response_definition+ afun <- make_afun( |
| 130 | -+ | 3x |
- )+ s_glm_count, |
| 131 | -48x | +3x |
- result <- h_logistic_simple_terms(+ .stats = .stats, |
| 132 | -48x | +3x |
- x = bm,+ .formats = .formats, |
| 133 | -48x | +3x |
- fit_glm = model_fit,+ .labels = .labels, |
| 134 | -48x | +3x |
- conf_level = control$conf_level+ .indent_mods = .indent_mods, |
| 135 | -+ | 3x |
- )+ .null_ref_cells = FALSE |
| 136 | -48x | +
- resp_vector <- if (inherits(model_fit, "glm")) {
+ ) |
|
| 137 | -38x | +
- model_fit$model[[variables$rsp]]+ |
|
| 138 | -+ | 3x |
- } else {
+ analyze( |
| 139 | -10x | +3x |
- as.logical(as.matrix(model_fit$y)[, "status"])+ lyt, |
| 140 | -+ | 3x |
- }+ vars, |
| 141 | -48x | +3x |
- data.frame(+ var_labels = var_labels, |
| 142 | -+ | 3x |
- # Dummy column needed downstream to create a nested header.+ show_labels = show_labels, |
| 143 | -48x | +3x |
- biomarker = bm,+ table_names = table_names, |
| 144 | -48x | +3x |
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ afun = afun, |
| 145 | -48x | +3x |
- n_tot = length(resp_vector),+ na_str = na_str, |
| 146 | -48x | +3x |
- n_rsp = sum(resp_vector),+ nested = nested, |
| 147 | -48x | +3x |
- prop = mean(resp_vector),+ extra_args = extra_args |
| 148 | -48x | +
- or = as.numeric(result[1L, "odds_ratio"]),+ ) |
|
| 149 | -48x | +
- lcl = as.numeric(result[1L, "lcl"]),+ } |
|
| 150 | -48x | +
- ucl = as.numeric(result[1L, "ucl"]),+ |
|
| 151 | -48x | +
- conf_level = conf_level,+ #' @describeIn summarize_glm_count Statistics function that produces a named list of results |
|
| 152 | -48x | +
- pval = as.numeric(result[1L, "pvalue"]),+ #' of the investigated Poisson model. |
|
| 153 | -48x | +
- pval_label = pval_label,+ #' |
|
| 154 | -48x | +
- stringsAsFactors = FALSE+ #' @return |
|
| 155 |
- )+ #' * `s_glm_count()` returns a named `list` of 5 statistics: |
||
| 156 |
- })+ #' * `n`: Count of complete sample size for the group. |
||
| 157 | -27x | +
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' * `rate`: Estimated event rate per follow-up time. |
|
| 158 |
- } else {
+ #' * `rate_ci`: Confidence level for estimated rate per follow-up time. |
||
| 159 | -1x | +
- data.frame(+ #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm. |
|
| 160 | -1x | +
- biomarker = variables$biomarkers,+ #' * `rate_ratio_ci`: Confidence level for the rate ratio. |
|
| 161 | -1x | +
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ #' * `pval`: p-value. |
|
| 162 | -1x | +
- n_tot = 0L,+ #' |
|
| 163 | -1x | +
- n_rsp = 0L,+ #' @keywords internal |
|
| 164 | -1x | +
- prop = NA,+ s_glm_count <- function(df, |
|
| 165 | -1x | +
- or = NA,+ .var, |
|
| 166 | -1x | +
- lcl = NA,+ .df_row, |
|
| 167 | -1x | +
- ucl = NA,+ variables, |
|
| 168 | -1x | +
- conf_level = conf_level,+ .ref_group, |
|
| 169 | -1x | +
- pval = NA,+ .in_ref_col, |
|
| 170 | -1x | +
- pval_label = pval_label,+ distribution, |
|
| 171 | -1x | +
- row.names = seq_along(variables$biomarkers),+ conf_level, |
|
| 172 | -1x | +
- stringsAsFactors = FALSE+ rate_mean_method, |
|
| 173 |
- )+ weights, |
||
| 174 |
- }+ scale = 1) {
|
||
| 175 | -+ | 14x |
- }+ arm <- variables$arm |
| 177 | -+ | 14x |
- #' @describeIn h_response_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing+ y <- df[[.var]] |
| 178 | -+ | 13x |
- #' the results for a single biomarker.+ smry_level <- as.character(unique(df[[arm]])) |
| 179 |
- #'+ |
||
| 180 |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ # ensure there is only 1 value |
||
| 181 | -+ | 13x |
- #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are+ checkmate::assert_scalar(smry_level) |
| 182 |
- #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()],+ |
||
| 183 | -+ | 13x |
- #' see the example).+ results <- h_glm_count( |
| 184 | -+ | 13x |
- #'+ .var = .var, |
| 185 | -+ | 13x |
- #' @return+ .df_row = .df_row, |
| 186 | -+ | 13x |
- #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ variables = variables, |
| 187 | -+ | 13x |
- #'+ distribution = distribution, |
| 188 | -+ | 13x |
- #' @examples+ weights |
| 189 |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ ) |
||
| 190 |
- #' df1 <- df[1, ]+ |
||
| 191 | -+ | 13x |
- #' df1$subgroup <- "All patients"+ if (rate_mean_method == "emmeans") {
|
| 192 | -+ | 13x |
- #' df1$row_type <- "content"+ emmeans_smry <- summary(results$emmeans_fit, level = conf_level) |
| 193 | -+ | ! |
- #' df1$var <- "ALL"+ } else if (rate_mean_method == "ppmeans") {
|
| 194 | -+ | ! |
- #' df1$var_label <- "All patients"+ emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level) |
| 195 |
- #'+ } |
||
| 196 |
- #' h_tab_rsp_one_biomarker(+ |
||
| 197 | -+ | 13x |
- #' df1,+ emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ] |
| 198 |
- #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
+
|
||
| 199 |
- #' )+ # This happens if there is a reference col. No Ratio is calculated? |
||
| 200 | -+ | 13x |
- #'+ if (.in_ref_col) {
|
| 201 | -+ | 5x |
- #' @export+ list( |
| 202 | -+ | 5x |
- h_tab_rsp_one_biomarker <- function(df,+ n = length(y[!is.na(y)]), |
| 203 | -+ | 5x |
- vars,+ rate = formatters::with_label( |
| 204 | -+ | 5x |
- na_str = default_na_str(),+ ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate * scale), |
| 205 | -+ | 5x |
- .indent_mods = 0L) {
+ "Adjusted Rate" |
| 206 | -8x | +
- afuns <- a_response_subgroups(na_str = na_str)[vars]+ ), |
|
| 207 | -8x | +5x |
- colvars <- d_rsp_subgroups_colvars(+ rate_ci = formatters::with_label( |
| 208 | -8x | +5x |
- vars,+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
| 209 | -8x | +5x |
- conf_level = df$conf_level[1],+ f_conf_level(conf_level) |
| 210 | -8x | +
- method = df$pval_label[1]+ ), |
|
| 211 | -+ | 5x |
- )+ rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"), |
| 212 | -8x | +5x |
- h_tab_one_biomarker(+ rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)), |
| 213 | -8x | +5x |
- df = df,+ pval = formatters::with_label(character(), "p-value") |
| 214 | -8x | +
- afuns = afuns,+ ) |
|
| 215 | -8x | +
- colvars = colvars,+ } else {
|
|
| 216 | 8x |
- na_str = na_str,+ emmeans_contrasts <- emmeans::contrast( |
|
| 217 | 8x |
- .indent_mods = .indent_mods+ results$emmeans_fit, |
|
| 218 | -+ | 8x |
- )+ method = "trt.vs.ctrl", |
| 219 | -+ | 8x |
- }+ ref = grep( |
| 1 | -+ | |||
| 220 | +8x |
- #' Estimate proportions of each level of a variable+ as.character(unique(.ref_group[[arm]])), |
||
| 2 | -+ | |||
| 221 | +8x |
- #'+ as.data.frame(results$emmeans_fit)[[arm]] |
||
| 3 | +222 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 4 | +223 |
- #'+ ) |
||
| 5 | +224 |
- #' The analyze & summarize function [estimate_multinomial_response()] creates a layout element to estimate the+ |
||
| 6 | -+ | |||
| 225 | +8x |
- #' proportion and proportion confidence interval for each level of a factor variable. The primary analysis variable,+ contrasts_smry <- summary( |
||
| 7 | -+ | |||
| 226 | +8x |
- #' `var`, should be a factor variable, the values of which will be used as labels within the output table.+ emmeans_contrasts, |
||
| 8 | -+ | |||
| 227 | +8x |
- #'+ infer = TRUE, |
||
| 9 | -+ | |||
| 228 | +8x |
- #' @inheritParams argument_convention+ adjust = "none" |
||
| 10 | +229 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ ) |
||
| 11 | +230 |
- #'+ |
||
| 12 | -+ | |||
| 231 | +8x |
- #' Options are: ``r shQuote(get_stats("estimate_multinomial_response"))``
+ smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ] |
||
| 13 | +232 |
- #'+ |
||
| 14 | -+ | |||
| 233 | +8x |
- #' @seealso Relevant description function [d_onco_rsp_label()].+ list( |
||
| 15 | -+ | |||
| 234 | +8x |
- #'+ n = length(y[!is.na(y)]), |
||
| 16 | -+ | |||
| 235 | +8x |
- #' @name estimate_multinomial_rsp+ rate = formatters::with_label( |
||
| 17 | -+ | |||
| 236 | +8x |
- #' @order 1+ ifelse(distribution == "negbin", |
||
| 18 | -+ | |||
| 237 | +8x |
- NULL+ emmeans_smry_level$response * scale, |
||
| 19 | -+ | |||
| 238 | +8x |
-
+ emmeans_smry_level$rate * scale |
||
| 20 | +239 |
- #' Description of standard oncology response+ ), |
||
| 21 | -+ | |||
| 240 | +8x |
- #'+ "Adjusted Rate" |
||
| 22 | +241 |
- #' @description `r lifecycle::badge("stable")`
+ ), |
||
| 23 | -+ | |||
| 242 | +8x |
- #'+ rate_ci = formatters::with_label( |
||
| 24 | -+ | |||
| 243 | +8x |
- #' Describe the oncology response in a standard way.+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
||
| 25 | -+ | |||
| 244 | +8x |
- #'+ f_conf_level(conf_level) |
||
| 26 | +245 |
- #' @param x (`character`)\cr the standard oncology codes to be described.+ ), |
||
| 27 | -+ | |||
| 246 | +8x |
- #'+ rate_ratio = formatters::with_label( |
||
| 28 | -+ | |||
| 247 | +8x |
- #' @return Response labels.+ smry_contrasts_level$ratio, |
||
| 29 | -+ | |||
| 248 | +8x |
- #'+ "Adjusted Rate Ratio" |
||
| 30 | +249 |
- #' @seealso [estimate_multinomial_rsp()]+ ), |
||
| 31 | -+ | |||
| 250 | +8x |
- #'+ rate_ratio_ci = formatters::with_label( |
||
| 32 | -+ | |||
| 251 | +8x |
- #' @examples+ c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL), |
||
| 33 | -+ | |||
| 252 | +8x |
- #' d_onco_rsp_label(+ f_conf_level(conf_level) |
||
| 34 | +253 |
- #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
+ ), |
||
| 35 | -+ | |||
| 254 | +8x |
- #' )+ pval = formatters::with_label( |
||
| 36 | -+ | |||
| 255 | +8x |
- #'+ smry_contrasts_level$p.value, |
||
| 37 | -+ | |||
| 256 | +8x |
- #' # Adding some values not considered in d_onco_rsp_label+ "p-value" |
||
| 38 | +257 |
- #'+ ) |
||
| 39 | +258 |
- #' d_onco_rsp_label(+ ) |
||
| 40 | +259 |
- #' c("CR", "PR", "hello", "hi")
+ } |
||
| 41 | +260 |
- #' )+ } |
||
| 42 | +261 |
- #'+ # h_glm_count ------------------------------------------------------------------ |
||
| 43 | +262 |
- #' @export+ #' Helper functions for Poisson models |
||
| 44 | +263 |
- d_onco_rsp_label <- function(x) {
- |
- ||
| 45 | -2x | -
- x <- as.character(x)- |
- ||
| 46 | -2x | -
- desc <- c(+ #' |
||
| 47 | -2x | +|||
| 264 | +
- CR = "Complete Response (CR)",+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 48 | -2x | +|||
| 265 | +
- PR = "Partial Response (PR)",+ #' |
|||
| 49 | -2x | +|||
| 266 | +
- MR = "Minimal/Minor Response (MR)",+ #' Helper functions that returns the results of [stats::glm()] when Poisson or Quasi-Poisson |
|||
| 50 | -2x | +|||
| 267 | +
- MRD = "Minimal Residual Disease (MRD)",+ #' distributions are needed (see `family` parameter), or [MASS::glm.nb()] for Negative Binomial |
|||
| 51 | -2x | +|||
| 268 | +
- SD = "Stable Disease (SD)",+ #' distributions. Link function for the GLM is `log`. |
|||
| 52 | -2x | +|||
| 269 | +
- PD = "Progressive Disease (PD)",+ #' |
|||
| 53 | -2x | +|||
| 270 | +
- `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)",+ #' @inheritParams argument_convention |
|||
| 54 | -2x | +|||
| 271 | +
- NE = "Not Evaluable (NE)",+ #' |
|||
| 55 | -2x | +|||
| 272 | +
- `NE/Missing` = "Missing or unevaluable",+ #' @seealso [summarize_glm_count] |
|||
| 56 | -2x | +|||
| 273 | +
- Missing = "Missing",+ #' |
|||
| 57 | -2x | +|||
| 274 | +
- `NA` = "Not Applicable (NA)",+ #' @name h_glm_count |
|||
| 58 | -2x | +|||
| 275 | +
- ND = "Not Done (ND)"+ NULL |
|||
| 59 | +276 |
- )+ |
||
| 60 | +277 |
-
+ #' @describeIn h_glm_count Helper function to return the results of the |
||
| 61 | -2x | +|||
| 278 | +
- values_label <- vapply(+ #' selected model (Poisson, Quasi-Poisson, negative binomial). |
|||
| 62 | -2x | +|||
| 279 | +
- X = x,+ #' |
|||
| 63 | -2x | +|||
| 280 | +
- FUN.VALUE = character(1),+ #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called |
|||
| 64 | -2x | +|||
| 281 | +
- function(val) {
+ #' in `.var` and `variables`. |
|||
| 65 | -! | +|||
| 282 | +
- if (val %in% names(desc)) desc[val] else val+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with |
|||
| 66 | +283 |
- }+ #' expected elements: |
||
| 67 | +284 |
- )+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple |
||
| 68 | +285 |
-
+ #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the |
||
| 69 | -2x | +|||
| 286 | +
- return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc))))+ #' reference group. |
|||
| 70 | +287 |
- }+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as |
||
| 71 | +288 |
-
+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
||
| 72 | +289 |
- #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number+ #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset. |
||
| 73 | +290 |
- #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()].+ #' @param distribution (`character`)\cr a character value specifying the distribution |
||
| 74 | +291 |
- #'+ #' used in the regression (Poisson, Quasi-Poisson, negative binomial). |
||
| 75 | +292 |
- #' @return+ #' @param weights (`character`)\cr a character vector specifying weights used |
||
| 76 | +293 |
- #' * `s_length_proportion()` returns statistics from [s_proportion()].+ #' in averaging predictions. Number of weights must equal the number of levels included in the covariates. |
||
| 77 | +294 |
- #'+ #' Weights option passed to [emmeans::emmeans()]. |
||
| 78 | +295 |
- #' @examples+ #' |
||
| 79 | +296 |
- #' s_length_proportion(rep("CR", 10), .N_col = 100)
+ #' @return |
||
| 80 | +297 |
- #' s_length_proportion(factor(character(0)), .N_col = 100)+ #' * `h_glm_count()` returns the results of the selected model. |
||
| 81 | +298 |
#' |
||
| 82 | +299 |
- #' @export+ #' @keywords internal |
||
| 83 | +300 |
- s_length_proportion <- function(x,+ h_glm_count <- function(.var, |
||
| 84 | +301 |
- .N_col, # nolint+ .df_row, |
||
| 85 | +302 |
- ...) {
+ variables, |
||
| 86 | -4x | +|||
| 303 | +
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ distribution, |
|||
| 87 | -3x | +|||
| 304 | +
- checkmate::assert_vector(x, min.len = 0, max.len = .N_col)+ weights) {
|
|||
| 88 | -2x | -
- checkmate::assert_vector(unique(x), min.len = 0, max.len = 1)- |
- ||
| 89 | -+ | 305 | +21x |
-
+ checkmate::assert_subset(distribution, c("poisson", "quasipoisson", "negbin"), empty.ok = FALSE)
|
| 90 | -1x | +306 | +19x |
- n_true <- length(x)+ switch(distribution, |
| 91 | -1x | +307 | +13x |
- n_false <- .N_col - n_true+ poisson = h_glm_poisson(.var, .df_row, variables, weights), |
| 92 | +308 | 1x |
- x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false))+ quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights), |
|
| 93 | -1x | +309 | +5x |
- s_proportion(df = x_logical, ...)+ negbin = h_glm_negbin(.var, .df_row, variables, weights) |
| 94 | +310 |
- }+ ) |
||
| 95 | +311 |
-
+ } |
||
| 96 | +312 |
- #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun`+ |
||
| 97 | +313 |
- #' in `estimate_multinomial_response()`.+ #' @describeIn h_glm_count Helper function to return results of a Poisson model. |
||
| 98 | +314 |
#' |
||
| 99 | +315 |
#' @return |
||
| 100 | +316 |
- #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `h_glm_poisson()` returns the results of a Poisson model. |
||
| 101 | +317 |
#' |
||
| 102 | +318 |
- #' @examples+ #' @keywords internal |
||
| 103 | +319 |
- #' a_length_proportion(rep("CR", 10), .N_col = 100)
+ h_glm_poisson <- function(.var, |
||
| 104 | +320 |
- #' a_length_proportion(factor(character(0)), .N_col = 100)+ .df_row, |
||
| 105 | +321 |
- #'+ variables, |
||
| 106 | +322 |
- #' @export+ weights) {
|
||
| 107 | -+ | |||
| 323 | +17x |
- a_length_proportion <- make_afun(+ arm <- variables$arm |
||
| 108 | -+ | |||
| 324 | +17x |
- s_length_proportion,+ covariates <- variables$covariates |
||
| 109 | -+ | |||
| 325 | +17x |
- .formats = c(+ offset <- .df_row[[variables$offset]] |
||
| 110 | +326 |
- n_prop = "xx (xx.x%)",+ |
||
| 111 | -+ | |||
| 327 | +15x |
- prop_ci = "(xx.xx, xx.xx)"+ formula <- stats::as.formula(paste0( |
||
| 112 | -+ | |||
| 328 | +15x |
- )+ .var, " ~ ", |
||
| 113 | +329 |
- )+ " + ", |
||
| 114 | -+ | |||
| 330 | +15x |
-
+ paste(covariates, collapse = " + "), |
||
| 115 | +331 |
- #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments+ " + ", |
||
| 116 | -+ | |||
| 332 | +15x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and+ arm |
||
| 117 | +333 |
- #' [rtables::summarize_row_groups()].+ )) |
||
| 118 | +334 |
- #'+ |
||
| 119 | -+ | |||
| 335 | +15x |
- #' @return+ glm_fit <- stats::glm( |
||
| 120 | -+ | |||
| 336 | +15x |
- #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions,+ formula = formula, |
||
| 121 | -+ | |||
| 337 | +15x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ offset = offset, |
||
| 122 | -+ | |||
| 338 | +15x |
- #' the statistics from `s_length_proportion()` to the table layout.+ data = .df_row, |
||
| 123 | -+ | |||
| 339 | +15x |
- #'+ family = stats::poisson(link = "log") |
||
| 124 | +340 |
- #' @examples+ ) |
||
| 125 | +341 |
- #' library(dplyr)+ |
||
| 126 | -+ | |||
| 342 | +15x |
- #'+ emmeans_fit <- emmeans::emmeans( |
||
| 127 | -+ | |||
| 343 | +15x |
- #' # Use of the layout creating function.+ glm_fit, |
||
| 128 | -+ | |||
| 344 | +15x |
- #' dta_test <- data.frame(+ specs = arm, |
||
| 129 | -+ | |||
| 345 | +15x |
- #' USUBJID = paste0("S", 1:12),
+ data = .df_row, |
||
| 130 | -+ | |||
| 346 | +15x |
- #' ARM = factor(rep(LETTERS[1:3], each = 4)),+ type = "response", |
||
| 131 | -+ | |||
| 347 | +15x |
- #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ offset = 0, |
||
| 132 | -+ | |||
| 348 | +15x |
- #' ) %>% mutate(+ weights = weights |
||
| 133 | +349 |
- #' AVALC = factor(AVAL,+ ) |
||
| 134 | +350 |
- #' levels = c(0, 1),+ |
||
| 135 | -+ | |||
| 351 | +15x |
- #' labels = c("Complete Response (CR)", "Partial Response (PR)")
+ list( |
||
| 136 | -+ | |||
| 352 | +15x |
- #' )+ glm_fit = glm_fit, |
||
| 137 | -+ | |||
| 353 | +15x |
- #' )+ emmeans_fit = emmeans_fit |
||
| 138 | +354 |
- #'+ ) |
||
| 139 | +355 |
- #' lyt <- basic_table() %>%+ } |
||
| 140 | +356 |
- #' split_cols_by("ARM") %>%
+
|
||
| 141 | +357 |
- #' estimate_multinomial_response(var = "AVALC")+ #' @describeIn h_glm_count Helper function to return results of a Quasi-Poisson model. |
||
| 142 | +358 |
#' |
||
| 143 | +359 |
- #' tbl <- build_table(lyt, dta_test)+ #' @return |
||
| 144 | +360 |
- #'+ #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model. |
||
| 145 | +361 |
- #' tbl+ #' |
||
| 146 | +362 |
- #'+ #' @keywords internal |
||
| 147 | +363 |
- #' @export+ h_glm_quasipoisson <- function(.var, |
||
| 148 | +364 |
- #' @order 2+ .df_row, |
||
| 149 | +365 |
- estimate_multinomial_response <- function(lyt,+ variables, |
||
| 150 | +366 |
- var,+ weights) {
|
||
| 151 | -+ | |||
| 367 | +5x |
- na_str = default_na_str(),+ arm <- variables$arm |
||
| 152 | -+ | |||
| 368 | +5x |
- nested = TRUE,+ covariates <- variables$covariates |
||
| 153 | -+ | |||
| 369 | +5x |
- ...,+ offset <- .df_row[[variables$offset]] |
||
| 154 | +370 |
- show_labels = "hidden",+ |
||
| 155 | -+ | |||
| 371 | +3x |
- table_names = var,+ formula <- stats::as.formula(paste0( |
||
| 156 | -+ | |||
| 372 | +3x |
- .stats = "prop_ci",+ .var, " ~ ", |
||
| 157 | +373 |
- .formats = NULL,+ " + ", |
||
| 158 | -+ | |||
| 374 | +3x |
- .labels = NULL,+ paste(covariates, collapse = " + "), |
||
| 159 | +375 |
- .indent_mods = NULL) {
+ " + ", |
||
| 160 | -1x | +376 | +3x |
- extra_args <- list(...)+ arm |
| 161 | +377 |
-
+ )) |
||
| 162 | -1x | +|||
| 378 | +
- afun <- make_afun(+ |
|||
| 163 | -1x | +379 | +3x |
- a_length_proportion,+ glm_fit <- stats::glm( |
| 164 | -1x | +380 | +3x |
- .stats = .stats,+ formula = formula, |
| 165 | -1x | +381 | +3x |
- .formats = .formats,+ offset = offset, |
| 166 | -1x | +382 | +3x |
- .labels = .labels,+ data = .df_row, |
| 167 | -1x | +383 | +3x |
- .indent_mods = .indent_mods+ family = stats::quasipoisson(link = "log") |
| 168 | +384 |
) |
||
| 169 | -1x | +|||
| 385 | +
- lyt <- split_rows_by(lyt, var = var)+ |
|||
| 170 | -1x | +386 | +3x |
- lyt <- summarize_row_groups(lyt, na_str = na_str)+ emmeans_fit <- emmeans::emmeans( |
| 171 | -+ | |||
| 387 | +3x |
-
+ glm_fit, |
||
| 172 | -1x | +388 | +3x |
- analyze(+ specs = arm, |
| 173 | -1x | +389 | +3x |
- lyt,+ data = .df_row, |
| 174 | -1x | +390 | +3x |
- vars = var,+ type = "response", |
| 175 | -1x | +391 | +3x |
- afun = afun,+ offset = 0, |
| 176 | -1x | +392 | +3x |
- show_labels = show_labels,+ weights = weights |
| 177 | -1x | +|||
| 393 | +
- table_names = table_names,+ )+ |
+ |||
| 394 | ++ | + | ||
| 178 | -1x | +395 | +3x |
- na_str = na_str,+ list( |
| 179 | -1x | +396 | +3x |
- nested = nested,+ glm_fit = glm_fit, |
| 180 | -1x | +397 | +3x |
- extra_args = extra_args+ emmeans_fit = emmeans_fit |
| 181 | +398 |
) |
||
| 182 | +399 |
} |
| 1 | +400 |
- #' Cox proportional hazards regression+ |
|
| 2 | +401 |
- #'+ #' @describeIn h_glm_count Helper function to return results of a negative binomial model. |
|
| 3 | +402 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
|
| 4 | +403 |
- #'+ #' @return |
|
| 5 | +404 |
- #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis.+ #' * `h_glm_negbin()` returns the results of a negative binomial model. |
|
| 6 | +405 |
#' |
|
| 7 | +406 |
- #' @inheritParams argument_convention+ #' @keywords internal |
|
| 8 | +407 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ h_glm_negbin <- function(.var, |
|
| 9 | +408 |
- #'+ .df_row, |
|
| 10 | +409 |
- #' Options are: ``r shQuote(get_stats("summarize_coxreg"))``
+ variables, |
|
| 11 | +410 |
- #'+ weights) {
|
|
| 12 | -+ | ||
| 411 | +9x |
- #' @details Cox models are the most commonly used methods to estimate the magnitude of+ arm <- variables$arm |
|
| 13 | -+ | ||
| 412 | +9x |
- #' the effect in survival analysis. It assumes proportional hazards: the ratio+ covariates <- variables$covariates |
|
| 14 | +413 |
- #' of the hazards between groups (e.g., two arms) is constant over time.+ |
|
| 15 | -+ | ||
| 414 | +9x |
- #' This ratio is referred to as the "hazard ratio" (HR) and is one of the+ formula <- stats::as.formula(paste0( |
|
| 16 | -+ | ||
| 415 | +9x |
- #' most commonly reported metrics to describe the effect size in survival+ .var, " ~ ", |
|
| 17 | +416 |
- #' analysis (NEST Team, 2020).+ " + ", |
|
| 18 | -+ | ||
| 417 | +9x |
- #'+ paste(covariates, collapse = " + "), |
|
| 19 | +418 |
- #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant+ " + ", |
|
| 20 | -+ | ||
| 419 | +9x |
- #' helper functions, and [tidy_coxreg] for custom tidy methods.+ arm |
|
| 21 | +420 |
- #'+ )) |
|
| 22 | +421 |
- #' @examples+ |
|
| 23 | -+ | ||
| 422 | +9x |
- #' library(survival)+ glm_fit <- MASS::glm.nb( |
|
| 24 | -+ | ||
| 423 | +9x |
- #'+ formula = formula, |
|
| 25 | -+ | ||
| 424 | +9x |
- #' # Testing dataset [survival::bladder].+ data = .df_row, |
|
| 26 | -+ | ||
| 425 | +9x |
- #' set.seed(1, kind = "Mersenne-Twister")+ link = "log" |
|
| 27 | +426 |
- #' dta_bladder <- with(+ ) |
|
| 28 | +427 |
- #' data = bladder[bladder$enum < 5, ],+ |
|
| 29 | -+ | ||
| 428 | +7x |
- #' tibble::tibble(+ emmeans_fit <- emmeans::emmeans( |
|
| 30 | -+ | ||
| 429 | +7x |
- #' TIME = stop,+ glm_fit,+ |
+ |
| 430 | +7x | +
+ specs = arm,+ |
+ |
| 431 | +7x | +
+ data = .df_row,+ |
+ |
| 432 | +7x | +
+ type = "response",+ |
+ |
| 433 | +7x | +
+ offset = 0,+ |
+ |
| 434 | +7x | +
+ weights = weights |
|
| 31 | +435 |
- #' STATUS = event,+ ) |
|
| 32 | +436 |
- #' ARM = as.factor(rx),+ + |
+ |
| 437 | +7x | +
+ list(+ |
+ |
| 438 | +7x | +
+ glm_fit = glm_fit,+ |
+ |
| 439 | +7x | +
+ emmeans_fit = emmeans_fit |
|
| 33 | +440 |
- #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
+ ) |
|
| 34 | +441 |
- #' COVAR2 = factor(+ } |
|
| 35 | +442 |
- #' sample(as.factor(enum)),+ |
|
| 36 | +443 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ # h_ppmeans -------------------------------------------------------------------- |
|
| 37 | +444 |
- #' ) %>% formatters::with_label("Sex (F/M)")
+ #' Function to return the estimated means using predicted probabilities |
|
| 38 | +445 |
- #' )+ #' |
|
| 39 | +446 |
- #' )+ #' @description |
|
| 40 | +447 |
- #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' For each arm level, the predicted mean rate is calculated using the fitted model object, with `newdata` |
|
| 41 | +448 |
- #' dta_bladder$STUDYID <- factor("X")
+ #' set to the result of `stats::model.frame`, a reconstructed data or the original data, depending on the |
|
| 42 | +449 |
- #'+ #' object formula (coming from the fit). The confidence interval is derived using the `conf_level` parameter. |
|
| 43 | +450 |
- #' u1_variables <- list(+ #' |
|
| 44 | +451 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm. |
|
| 45 | +452 |
- #' )+ #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called in `.var` and `variables`. |
|
| 46 | +453 |
- #'+ #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
|
| 47 | +454 |
- #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
|
| 48 | +455 |
- #'+ #' @param conf_level (`proportion`)\cr value used to derive the confidence interval for the rate. |
|
| 49 | +456 |
- #' m1_variables <- list(+ #' |
|
| 50 | +457 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' @return |
|
| 51 | +458 |
- #' )+ #' * `h_ppmeans()` returns the estimated means. |
|
| 52 | +459 |
#' |
|
| 53 | +460 |
- #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ #' @seealso [summarize_glm_count()]. |
|
| 54 | +461 |
#' |
|
| 55 | +462 |
- #' @name cox_regression+ #' @export |
|
| 56 | +463 |
- #' @order 1+ h_ppmeans <- function(obj, .df_row, arm, conf_level) {
|
|
| 57 | -+ | ||
| 464 | +1x |
- NULL+ alpha <- 1 - conf_level+ |
+ |
| 465 | +1x | +
+ p <- 1 - alpha / 2 |
|
| 58 | +466 | ||
| 59 | -+ | ||
| 467 | +1x |
- #' @describeIn cox_regression Statistics function that transforms results tabulated+ arm_levels <- levels(.df_row[[arm]]) |
|
| 60 | +468 |
- #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list.+ |
|
| 61 | -+ | ||
| 469 | +1x |
- #'+ out <- lapply(arm_levels, function(lev) {
+ |
+ |
| 470 | +3x | +
+ temp <- .df_row+ |
+ |
| 471 | +3x | +
+ temp[[arm]] <- factor(lev, levels = arm_levels) |
|
| 62 | +472 |
- #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg]+ + |
+ |
| 473 | +3x | +
+ mf <- stats::model.frame(obj$formula, data = temp)+ |
+ |
| 474 | +3x | +
+ X <- stats::model.matrix(obj$formula, data = mf) # nolint |
|
| 63 | +475 |
- #' function with tidying applied via [broom::tidy()].+ + |
+ |
| 476 | +3x | +
+ rate <- stats::predict(obj, newdata = mf, type = "response")+ |
+ |
| 477 | +3x | +
+ rate_hat <- mean(rate) |
|
| 64 | +478 |
- #' @param .stats (`character`)\cr the names of statistics to be reported among:+ + |
+ |
| 479 | +3x | +
+ zz <- colMeans(rate * X)+ |
+ |
| 480 | +3x | +
+ se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz))+ |
+ |
| 481 | +3x | +
+ rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat)+ |
+ |
| 482 | +3x | +
+ rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat) |
|
| 65 | +483 |
- #' * `n`: number of observations (univariate only)+ + |
+ |
| 484 | +3x | +
+ c(rate_hat, rate_lwr, rate_upr) |
|
| 66 | +485 |
- #' * `hr`: hazard ratio+ }) |
|
| 67 | +486 |
- #' * `ci`: confidence interval+ + |
+ |
| 487 | +1x | +
+ names(out) <- arm_levels+ |
+ |
| 488 | +1x | +
+ out <- do.call(rbind, out)+ |
+ |
| 489 | +1x | +
+ if ("negbin" %in% class(obj)) {
+ |
+ |
| 490 | +! | +
+ colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
|
|
| 68 | +491 |
- #' * `pval`: p-value of the treatment effect+ } else {
+ |
+ |
| 492 | +1x | +
+ colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
|
|
| 69 | +493 |
- #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only)+ }+ |
+ |
| 494 | +1x | +
+ out <- as.data.frame(out)+ |
+ |
| 495 | +1x | +
+ out[[arm]] <- rownames(out)+ |
+ |
| 496 | +1x | +
+ out |
|
| 70 | +497 |
- #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model.+ } |
| 71 | +1 |
- #' Defaults to `"all"`. Other options include `"var_main"` for main effects, `"inter"` for interaction effects,+ #' Missing data |
||
| 72 | +2 |
- #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is `"all"`, specific+ #' |
||
| 73 | +3 |
- #' variables can be selected by specifying `.var_nms`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 74 | +4 |
- #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically+ #' |
||
| 75 | +5 |
- #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired+ #' Substitute missing data with a string or factor level. |
||
| 76 | +6 |
- #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars`+ #' |
||
| 77 | +7 |
- #' is `"var_main"`, `.var_nms` should be only the variable name.+ #' @param x (`factor` or `character`)\cr values for which any missing values should be substituted. |
||
| 78 | +8 |
- #'+ #' @param label (`string`)\cr string that missing data should be replaced with. |
||
| 79 | +9 |
- #' @return+ #' |
||
| 80 | +10 |
- #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s).+ #' @return `x` with any `NA` values substituted by `label`. |
||
| 81 | +11 |
#' |
||
| 82 | +12 |
#' @examples |
||
| 83 | +13 |
- #' # s_coxreg+ #' explicit_na(c(NA, "a", "b")) |
||
| 84 | +14 |
- #'+ #' is.na(explicit_na(c(NA, "a", "b"))) |
||
| 85 | +15 |
- #' # Univariate+ #' |
||
| 86 | +16 |
- #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder)+ #' explicit_na(factor(c(NA, "a", "b"))) |
||
| 87 | +17 |
- #' df1 <- broom::tidy(univar_model)+ #' is.na(explicit_na(factor(c(NA, "a", "b")))) |
||
| 88 | +18 |
#' |
||
| 89 | +19 |
- #' s_coxreg(model_df = df1, .stats = "hr")+ #' explicit_na(sas_na(c("a", "")))
|
||
| 90 | +20 |
#' |
||
| 91 | +21 |
- #' # Univariate with interactions+ #' @export |
||
| 92 | +22 |
- #' univar_model_inter <- fit_coxreg_univar(+ explicit_na <- function(x, label = "<Missing>") {
|
||
| 93 | -+ | |||
| 23 | +254x |
- #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder+ checkmate::assert_string(label) |
||
| 94 | +24 |
- #' )+ |
||
| 95 | -+ | |||
| 25 | +254x |
- #' df1_inter <- broom::tidy(univar_model_inter)+ if (is.factor(x)) {
|
||
| 96 | -+ | |||
| 26 | +151x |
- #'+ x <- forcats::fct_na_value_to_level(x, label)+ |
+ ||
| 27 | +151x | +
+ forcats::fct_drop(x, only = label)+ |
+ ||
| 28 | +103x | +
+ } else if (is.character(x)) {
+ |
+ ||
| 29 | +103x | +
+ x[is.na(x)] <- label+ |
+ ||
| 30 | +103x | +
+ x |
||
| 97 | +31 |
- #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1")+ } else {
+ |
+ ||
| 32 | +! | +
+ stop("only factors and character vectors allowed")
|
||
| 98 | +33 |
- #'+ } |
||
| 99 | +34 |
- #' # Univariate without treatment arm - only "COVAR2" covariate effects+ } |
||
| 100 | +35 |
- #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder)+ |
||
| 101 | +36 |
- #' df1_covs <- broom::tidy(univar_covs_model)+ #' Convert strings to `NA` |
||
| 102 | +37 |
#' |
||
| 103 | +38 |
- #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
+ #' @description `r lifecycle::badge("stable")`
|
||
| 104 | +39 |
#' |
||
| 105 | +40 |
- #' # Multivariate.+ #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to |
||
| 106 | +41 |
- #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder)+ #' convert these values to `NA`s. |
||
| 107 | +42 |
- #' df2 <- broom::tidy(multivar_model)+ #' |
||
| 108 | +43 |
- #'+ #' @inheritParams explicit_na |
||
| 109 | +44 |
- #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1")+ #' @param empty (`flag`)\cr if `TRUE`, empty strings get replaced by `NA`. |
||
| 110 | +45 |
- #' s_coxreg(+ #' @param whitespaces (`flag`)\cr if `TRUE`, strings made from only whitespaces get replaced with `NA`. |
||
| 111 | +46 |
- #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl",+ #' |
||
| 112 | +47 |
- #' .var_nms = c("COVAR1", "A Covariate Label")
+ #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of |
||
| 113 | +48 |
- #' )+ #' `empty` and `whitespaces`. |
||
| 114 | +49 |
#' |
||
| 115 | +50 |
- #' # Multivariate without treatment arm - only "COVAR1" main effect+ #' @examples |
||
| 116 | +51 |
- #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder)+ #' sas_na(c("1", "", " ", " ", "b"))
|
||
| 117 | +52 |
- #' df2_covs <- broom::tidy(multivar_covs_model)+ #' sas_na(factor(c("", " ", "b")))
|
||
| 118 | +53 |
#' |
||
| 119 | +54 |
- #' s_coxreg(model_df = df2_covs, .stats = "hr")+ #' is.na(sas_na(c("1", "", " ", " ", "b")))
|
||
| 120 | +55 |
#' |
||
| 121 | +56 |
#' @export |
||
| 122 | +57 |
- s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
- |
- ||
| 123 | -291x | -
- assert_df_with_variables(model_df, list(term = "term", stat = .stats))- |
- ||
| 124 | -291x | -
- checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
+ sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
|
||
| 125 | -291x | +58 | +243x |
- model_df$term <- as.character(model_df$term)+ checkmate::assert_flag(empty) |
| 126 | -291x | +59 | +243x |
- .var_nms <- .var_nms[!is.na(.var_nms)]+ checkmate::assert_flag(whitespaces) |
| 127 | +60 | |||
| 128 | -289x | +61 | +243x |
- if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ]+ if (is.factor(x)) {
|
| 129 | -69x | +62 | +135x |
- if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1)+ empty_levels <- levels(x) == "" |
| 130 | -+ | |||
| 63 | +11x |
-
+ if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA |
||
| 131 | +64 |
- # We need a list with names corresponding to the stats to display of equal length to the list of stats.+ |
||
| 132 | -291x | +65 | +135x |
- y <- split(model_df, f = model_df$term, drop = FALSE)+ ws_levels <- grepl("^\\s+$", levels(x))
|
| 133 | -291x | +|||
| 66 | +! |
- y <- stats::setNames(y, nm = rep(.stats, length(y)))+ if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA |
||
| 134 | +67 | |||
| 135 | -291x | -
- if (.which_vars == "var_main") {
- |
- ||
| 136 | -128x | +68 | +135x |
- y <- lapply(y, function(x) x[1, ]) # only main effect+ x |
| 137 | -163x | +69 | +108x |
- } else if (.which_vars %in% c("inter", "multi_lvl")) {
+ } else if (is.character(x)) {
|
| 138 | -120x | -
- y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect- |
- ||
| 139 | -+ | 70 | +108x |
- }+ if (empty) x[x == ""] <- NA_character_ |
| 140 | +71 | |||
| 141 | -291x | -
- lapply(- |
- ||
| 142 | -291x | +72 | +108x |
- X = y,+ if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
|
| 143 | -291x | +|||
| 73 | +
- FUN = function(x) {
+
|
|||
| 144 | -295x | +74 | +108x |
- z <- as.list(x[[.stats]])+ x |
| 145 | -295x | +|||
| 75 | +
- stats::setNames(z, nm = x$term_label)+ } else {
|
|||
| 146 | -+ | |||
| 76 | +! |
- }+ stop("only factors and character vectors allowed")
|
||
| 147 | +77 |
- )+ } |
||
| 148 | +78 |
} |
| 149 | +1 |
-
+ #' Tabulate binary response by subgroup |
||
| 150 | +2 |
- #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()]+ #' |
||
| 151 | +3 |
- #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 152 | +4 |
#' |
||
| 153 | +5 |
- #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`.+ #' The [tabulate_rsp_subgroups()] function creates a layout element to tabulate binary response by subgroup, returning |
||
| 154 | +6 |
- #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`.+ #' statistics including response rate and odds ratio for each population subgroup. The table is created from `df`, a |
||
| 155 | +7 |
- #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`.+ #' list of data frames returned by [extract_rsp_subgroups()], with the statistics to include specified via the `vars` |
||
| 156 | +8 |
- #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to+ #' parameter. |
||
| 157 | +9 |
- #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching).+ #' |
||
| 158 | +10 |
- #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 159 | +11 |
- #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing+ #' |
||
| 160 | +12 |
- #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding+ #' @inheritParams extract_rsp_subgroups |
||
| 161 | +13 |
- #' effect estimates will be tabulated later.+ #' @inheritParams argument_convention |
||
| 162 | +14 |
#' |
||
| 163 | +15 |
- #' @return+ #' @details These functions create a layout starting from a data frame which contains |
||
| 164 | +16 |
- #' * `a_coxreg()` returns formatted [rtables::CellValue()].+ #' the required statistics. Tables typically used as part of forest plot. |
||
| 165 | +17 |
#' |
||
| 166 | +18 |
- #' @examples+ #' @seealso [extract_rsp_subgroups()] |
||
| 167 | +19 |
- #' a_coxreg(+ #' |
||
| 168 | +20 |
- #' df = dta_bladder,+ #' @examples |
||
| 169 | +21 |
- #' labelstr = "Label 1",+ #' library(dplyr) |
||
| 170 | +22 |
- #' variables = u1_variables,+ #' library(forcats) |
||
| 171 | +23 |
- #' .spl_context = list(value = "COVAR1"),+ #' |
||
| 172 | +24 |
- #' .stats = "n",+ #' adrs <- tern_ex_adrs |
||
| 173 | +25 |
- #' .formats = "xx"+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 174 | +26 |
- #' )+ #' |
||
| 175 | +27 |
- #'+ #' adrs_f <- adrs %>% |
||
| 176 | +28 |
- #' a_coxreg(+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 177 | +29 |
- #' df = dta_bladder,+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 178 | +30 |
- #' labelstr = "",+ #' droplevels() %>% |
||
| 179 | +31 |
- #' variables = u1_variables,+ #' mutate( |
||
| 180 | +32 |
- #' .spl_context = list(value = "COVAR2"),+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 181 | +33 |
- #' .stats = "pval",+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 182 | +34 |
- #' .formats = "xx.xxxx"+ #' rsp = AVALC == "CR" |
||
| 183 | +35 |
- #' )+ #' ) |
||
| 184 | +36 |
- #'+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 185 | +37 |
- #' @export+ #' |
||
| 186 | +38 |
- a_coxreg <- function(df,+ #' # Unstratified analysis. |
||
| 187 | +39 |
- labelstr,+ #' df <- extract_rsp_subgroups( |
||
| 188 | +40 |
- eff = FALSE,+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 189 | +41 |
- var_main = FALSE,+ #' data = adrs_f |
||
| 190 | +42 |
- multivar = FALSE,+ #' ) |
||
| 191 | +43 |
- variables,+ #' df |
||
| 192 | +44 |
- at = list(),+ #' |
||
| 193 | +45 |
- control = control_coxreg(),+ #' # Stratified analysis. |
||
| 194 | +46 |
- .spl_context,+ #' df_strat <- extract_rsp_subgroups( |
||
| 195 | +47 |
- .stats,+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"),
|
||
| 196 | +48 |
- .formats,+ #' data = adrs_f |
||
| 197 | +49 |
- .indent_mods = NULL,+ #' ) |
||
| 198 | +50 |
- na_str = "",+ #' df_strat |
||
| 199 | +51 |
- cache_env = NULL) {
+ #' |
||
| 200 | -288x | +|||
| 52 | +
- cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm+ #' # Grouping of the BMRKR2 levels. |
|||
| 201 | -288x | +|||
| 53 | +
- cov <- tail(.spl_context$value, 1) # current variable/covariate+ #' df_grouped <- extract_rsp_subgroups( |
|||
| 202 | -288x | +|||
| 54 | +
- var_lbl <- formatters::var_labels(df)[cov] # check for df labels+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|||
| 203 | -288x | +|||
| 55 | +
- if (length(labelstr) > 1) {
+ #' data = adrs_f, |
|||
| 204 | -8x | +|||
| 56 | +
- labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none+ #' groups_lists = list( |
|||
| 205 | -280x | +|||
| 57 | +
- } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
+ #' BMRKR2 = list( |
|||
| 206 | -67x | +|||
| 58 | +
- labelstr <- var_lbl+ #' "low" = "LOW", |
|||
| 207 | +59 |
- }+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 208 | -288x | +|||
| 60 | +
- if (eff || multivar || cov_no_arm) {
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|||
| 209 | -143x | +|||
| 61 | +
- control$interaction <- FALSE+ #' ) |
|||
| 210 | +62 |
- } else {
+ #' ) |
||
| 211 | -145x | +|||
| 63 | +
- variables$covariates <- cov+ #' ) |
|||
| 212 | -50x | +|||
| 64 | +
- if (var_main) control$interaction <- TRUE+ #' df_grouped |
|||
| 213 | +65 |
- }+ #' |
||
| 214 | +66 | ++ |
+ #' @name response_subgroups+ |
+ |
| 67 | ++ |
+ #' @order 1+ |
+ ||
| 68 | ++ |
+ NULL+ |
+ ||
| 69 | ||||
| 215 | -288x | +|||
| 70 | +
- if (is.null(cache_env[[cov]])) {
+ #' Prepare response data for population subgroups in data frames |
|||
| 216 | -47x | +|||
| 71 | +
- if (!multivar) {
+ #' |
|||
| 217 | -32x | +|||
| 72 | +
- model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy()+ #' @description `r lifecycle::badge("stable")`
|
|||
| 218 | +73 |
- } else {
+ #' |
||
| 219 | -15x | +|||
| 74 | +
- model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy()+ #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper |
|||
| 220 | +75 |
- }+ #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two |
||
| 221 | -47x | +|||
| 76 | +
- cache_env[[cov]] <- model+ #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`, |
|||
| 222 | +77 |
- } else {
+ #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`. |
||
| 223 | -241x | +|||
| 78 | +
- model <- cache_env[[cov]]+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|||
| 224 | +79 |
- }+ #' |
||
| 225 | -148x | +|||
| 80 | +
- if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_+ #' @inheritParams argument_convention |
|||
| 226 | +81 |
-
+ #' @inheritParams response_subgroups |
||
| 227 | -288x | +|||
| 82 | +
- if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
+ #' @param label_all (`string`)\cr label for the total population analysis. |
|||
| 228 | -15x | +|||
| 83 | +
- multivar <- TRUE+ #' |
|||
| 229 | -3x | +|||
| 84 | +
- if (!cov_no_arm) var_main <- TRUE+ #' @return A named list of two elements: |
|||
| 230 | +85 |
- }+ #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`, |
||
| 231 | +86 |
-
+ #' `var_label`, and `row_type`. |
||
| 232 | -288x | +|||
| 87 | +
- vars_coxreg <- list(which_vars = "all", var_nms = NULL)+ #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, |
|||
| 233 | -288x | +|||
| 88 | +
- if (eff) {
+ #' `subgroup`, `var`, `var_label`, and `row_type`. |
|||
| 234 | -65x | +|||
| 89 | +
- if (multivar && !var_main) { # multivar treatment level
+ #' |
|||
| 235 | -12x | +|||
| 90 | +
- var_lbl_arm <- formatters::var_labels(df)[[variables$arm]]+ #' @seealso [response_subgroups] |
|||
| 236 | -12x | +|||
| 91 | +
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
+ #' |
|||
| 237 | +92 |
- } else { # treatment effect
+ #' @export |
||
| 238 | -53x | +|||
| 93 | +
- vars_coxreg["var_nms"] <- variables$arm+ extract_rsp_subgroups <- function(variables, |
|||
| 239 | -12x | +|||
| 94 | +
- if (var_main) vars_coxreg["which_vars"] <- "var_main"+ data, |
|||
| 240 | +95 |
- }+ groups_lists = list(), |
||
| 241 | +96 |
- } else {
+ conf_level = 0.95, |
||
| 242 | -223x | +|||
| 97 | +
- if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
+ method = NULL, |
|||
| 243 | -166x | +|||
| 98 | +
- vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
+ label_all = "All Patients") {
|
|||
| 244 | -57x | +99 | +14x |
- } else if (multivar) { # multivar covariate level
+ if ("strat" %in% names(variables)) {
|
| 245 | -57x | +|||
| 100 | +! |
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
+ warning( |
||
| 246 | -12x | +|||
| 101 | +! |
- if (var_main) model[cov, .stats] <- NA_real_+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ", |
||
| 247 | -+ | |||
| 102 | +! |
- }+ "was deprecated in tern 0.9.4.\n ", |
||
| 248 | -50x | +|||
| 103 | +! |
- if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 249 | +104 |
- }+ ) |
||
| 250 | -288x | +|||
| 105 | +! |
- var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]]+ variables[["strata"]] <- variables[["strat"]] |
||
| 251 | -288x | +|||
| 106 | +
- var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
+ } |
|||
| 252 | -27x | +|||
| 107 | +
- paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels+ |
|||
| 253 | -288x | +108 | +14x |
- } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) ||+ df_prop <- h_proportion_subgroups_df( |
| 254 | -288x | +109 | +14x |
- (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
+ variables, |
| 255 | -71x | +110 | +14x |
- labelstr # other main effect labels+ data, |
| 256 | -288x | +111 | +14x |
- } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
+ groups_lists = groups_lists, |
| 257 | -12x | +112 | +14x |
- "All" # multivar numeric covariate+ label_all = label_all |
| 258 | +113 |
- } else {
+ ) |
||
| 259 | -178x | +114 | +14x |
- names(var_vals)+ df_or <- h_odds_ratio_subgroups_df( |
| 260 | -+ | |||
| 115 | +14x |
- }+ variables, |
||
| 261 | -288x | +116 | +14x |
- in_rows(+ data, |
| 262 | -288x | +117 | +14x |
- .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods,+ groups_lists = groups_lists, |
| 263 | -288x | +118 | +14x |
- .formats = stats::setNames(rep(.formats, length(var_names)), var_names),+ conf_level = conf_level, |
| 264 | -288x | +119 | +14x |
- .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names)+ method = method, |
| 265 | -+ | |||
| 120 | +14x |
- )+ label_all = label_all |
||
| 266 | +121 |
- }+ ) |
||
| 267 | +122 | |||
| 123 | +14x | +
+ list(prop = df_prop, or = df_or)+ |
+ ||
| 268 | +124 |
- #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table+ } |
||
| 269 | +125 |
- #' layout. This function is a wrapper for several `rtables` layouting functions. This function+ |
||
| 270 | +126 |
- #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()].+ #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`. |
||
| 271 | +127 |
#' |
||
| 272 | +128 |
- #' @inheritParams fit_coxreg_univar+ #' @return |
||
| 273 | +129 |
- #' @param multivar (`flag`)\cr whether multivariate Cox regression should run (defaults to `FALSE`), otherwise+ #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 274 | +130 |
- #' univariate Cox regression will run.+ #' |
||
| 275 | +131 |
- #' @param common_var (`string`)\cr the name of a factor variable in the dataset which takes the same value+ #' @keywords internal |
||
| 276 | +132 |
- #' for all rows. This should be created during pre-processing if no such variable currently exists.+ a_response_subgroups <- function(.formats = list( |
||
| 277 | +133 |
- #' @param .section_div (`string` or `NA`)\cr string which should be repeated as a section divider between sections.+ n = "xx", # nolint start |
||
| 278 | +134 |
- #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between+ n_rsp = "xx", |
||
| 279 | +135 |
- #' treatment and covariate sections and the second between different covariates.+ prop = "xx.x%", |
||
| 280 | +136 |
- #'+ n_tot = "xx", |
||
| 281 | +137 |
- #' @return+ or = list(format_extreme_values(2L)), |
||
| 282 | +138 |
- #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions,+ ci = list(format_extreme_values_ci(2L)), |
||
| 283 | +139 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table+ pval = "x.xxxx | (<0.0001)", |
||
| 284 | +140 |
- #' containing the chosen statistics to the table layout.+ riskdiff = "xx.x (xx.x - xx.x)" # nolint end |
||
| 285 | +141 |
- #'+ ), |
||
| 286 | +142 |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`,+ na_str = default_na_str()) {
|
||
| 287 | -+ | |||
| 143 | +22x |
- #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate+ checkmate::assert_list(.formats) |
||
| 288 | -+ | |||
| 144 | +22x |
- #' Cox regression models, respectively.+ checkmate::assert_subset( |
||
| 289 | -+ | |||
| 145 | +22x |
- #'+ names(.formats), |
||
| 290 | -+ | |||
| 146 | +22x |
- #' @examples+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval", "riskdiff")
|
||
| 291 | +147 |
- #' # summarize_coxreg+ ) |
||
| 292 | +148 |
- #'+ + |
+ ||
| 149 | +22x | +
+ afun_lst <- Map(+ |
+ ||
| 150 | +22x | +
+ function(stat, fmt, na_str) {
+ |
+ ||
| 151 | +157x | +
+ function(df, labelstr = "", ...) {
+ |
+ ||
| 152 | +349x | +
+ in_rows(+ |
+ ||
| 153 | +349x | +
+ .list = as.list(df[[stat]]),+ |
+ ||
| 154 | +349x | +
+ .labels = as.character(df$subgroup),+ |
+ ||
| 155 | +349x | +
+ .formats = fmt,+ |
+ ||
| 156 | +349x | +
+ .format_na_strs = na_str |
||
| 293 | +157 |
- #' result_univar <- basic_table() %>%+ ) |
||
| 294 | +158 |
- #' summarize_coxreg(variables = u1_variables) %>%+ } |
||
| 295 | +159 |
- #' build_table(dta_bladder)+ },+ |
+ ||
| 160 | +22x | +
+ stat = names(.formats),+ |
+ ||
| 161 | +22x | +
+ fmt = .formats,+ |
+ ||
| 162 | +22x | +
+ na_str = na_str |
||
| 296 | +163 |
- #' result_univar+ ) |
||
| 297 | +164 |
- #'+ + |
+ ||
| 165 | +22x | +
+ afun_lst |
||
| 298 | +166 |
- #' result_univar_covs <- basic_table() %>%+ } |
||
| 299 | +167 |
- #' summarize_coxreg(+ |
||
| 300 | +168 |
- #' variables = u2_variables,+ #' @describeIn response_subgroups Table-creating function which creates a table |
||
| 301 | +169 |
- #' ) %>%+ #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
||
| 302 | +170 |
- #' build_table(dta_bladder)+ #' and [rtables::summarize_row_groups()]. |
||
| 303 | +171 |
- #' result_univar_covs+ #' |
||
| 304 | +172 |
- #'+ #' @param df (`list`)\cr a list of data frames containing all analysis variables. List should be |
||
| 305 | +173 |
- #' result_multivar <- basic_table() %>%+ #' created using [extract_rsp_subgroups()]. |
||
| 306 | +174 |
- #' summarize_coxreg(+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 307 | +175 |
- #' variables = m1_variables,+ #' * `n`: Total number of observations per group. |
||
| 308 | +176 |
- #' multivar = TRUE,+ #' * `n_rsp`: Number of responders per group. |
||
| 309 | +177 |
- #' ) %>%+ #' * `prop`: Proportion of responders. |
||
| 310 | +178 |
- #' build_table(dta_bladder)+ #' * `n_tot`: Total number of observations. |
||
| 311 | +179 |
- #' result_multivar+ #' * `or`: Odds ratio. |
||
| 312 | +180 |
- #'+ #' * `ci` : Confidence interval of odds ratio. |
||
| 313 | +181 |
- #' result_multivar_covs <- basic_table() %>%+ #' * `pval`: p-value of the effect. |
||
| 314 | +182 |
- #' summarize_coxreg(+ #' Note, the statistics `n_tot`, `or`, and `ci` are required. |
||
| 315 | +183 |
- #' variables = m2_variables,+ #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
||
| 316 | +184 |
- #' multivar = TRUE,+ #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
||
| 317 | +185 |
- #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
+ #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$prop$arm` will be used as `arm_x` and |
||
| 318 | +186 |
- #' ) %>%+ #' the second level as `arm_y`. |
||
| 319 | +187 |
- #' build_table(dta_bladder)+ #' |
||
| 320 | +188 |
- #' result_multivar_covs+ #' @return An `rtables` table summarizing binary response by subgroup. |
||
| 321 | +189 |
#' |
||
| 322 | +190 |
- #' @export+ #' @examples |
||
| 323 | +191 |
- #' @order 2+ #' # Table with default columns |
||
| 324 | +192 |
- summarize_coxreg <- function(lyt,+ #' basic_table() %>% |
||
| 325 | +193 |
- variables,+ #' tabulate_rsp_subgroups(df) |
||
| 326 | +194 |
- control = control_coxreg(),+ #' |
||
| 327 | +195 |
- at = list(),+ #' # Table with selected columns |
||
| 328 | +196 |
- multivar = FALSE,+ #' basic_table() %>% |
||
| 329 | +197 |
- common_var = "STUDYID",+ #' tabulate_rsp_subgroups( |
||
| 330 | +198 |
- .stats = c("n", "hr", "ci", "pval", "pval_inter"),
+ #' df = df, |
||
| 331 | +199 |
- .formats = c(+ #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
|
||
| 332 | +200 |
- n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)",+ #' ) |
||
| 333 | +201 |
- pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)"+ #' |
||
| 334 | +202 |
- ),+ #' # Table with risk difference column added |
||
| 335 | +203 |
- varlabels = NULL,+ #' basic_table() %>% |
||
| 336 | +204 |
- .indent_mods = NULL,+ #' tabulate_rsp_subgroups( |
||
| 337 | +205 |
- na_str = "",+ #' df, |
||
| 338 | +206 |
- .section_div = NA_character_) {
+ #' riskdiff = control_riskdiff( |
||
| 339 | -16x | +|||
| 207 | +
- if (multivar && control$interaction) {
+ #' arm_x = levels(df$prop$arm)[1], |
|||
| 340 | -1x | +|||
| 208 | +
- warning(paste(+ #' arm_y = levels(df$prop$arm)[2] |
|||
| 341 | -1x | +|||
| 209 | +
- "Interactions are not available for multivariate cox regression using summarize_coxreg.",+ #' ) |
|||
| 342 | -1x | +|||
| 210 | +
- "The model will be calculated without interaction effects."+ #' ) |
|||
| 343 | +211 |
- ))+ #' |
||
| 344 | +212 |
- }+ #' @export |
||
| 345 | -16x | +|||
| 213 | +
- if (control$interaction && !"arm" %in% names(variables)) {
+ #' @order 2 |
|||
| 346 | -1x | +|||
| 214 | +
- stop("To include interactions please specify 'arm' in variables.")
+ tabulate_rsp_subgroups <- function(lyt, |
|||
| 347 | +215 |
- }+ df, |
||
| 348 | +216 |
-
+ vars = c("n_tot", "n", "prop", "or", "ci"),
|
||
| 349 | -15x | +|||
| 217 | +
- .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
+ groups_lists = list(), |
|||
| 350 | -6x | +|||
| 218 | +
- intersect(c("hr", "ci", "pval"), .stats)
+ label_all = "All Patients", |
|||
| 351 | -15x | +|||
| 219 | +
- } else if (control$interaction) {
+ riskdiff = NULL, |
|||
| 352 | -5x | +|||
| 220 | +
- intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
+ na_str = default_na_str(), |
|||
| 353 | +221 |
- } else {
+ .formats = c( |
||
| 354 | -4x | +|||
| 222 | +
- intersect(c("n", "hr", "ci", "pval"), .stats)
+ n = "xx", n_rsp = "xx", prop = "xx.x%", n_tot = "xx", |
|||
| 355 | +223 |
- }+ or = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)), |
||
| 356 | -15x | +|||
| 224 | +
- stat_labels <- c(+ pval = "x.xxxx | (<0.0001)" |
|||
| 357 | -15x | +|||
| 225 | +
- n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),+ )) {
|
|||
| 358 | -15x | +226 | +13x |
- pval = "p-value", pval_inter = "Interaction p-value"+ checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 359 | -+ | |||
| 227 | +13x |
- )+ checkmate::assert_true(all(c("n_tot", "or", "ci") %in% vars))
|
||
| 360 | -15x | +228 | +13x |
- stat_labels <- stat_labels[names(stat_labels) %in% .stats]+ if ("pval" %in% vars && !"pval" %in% names(df$or)) {
|
| 361 | -15x | +229 | +1x |
- .formats <- .formats[names(.formats) %in% .stats]+ warning( |
| 362 | -15x | +230 | +1x |
- env <- new.env() # create caching environment+ 'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ', |
| 363 | -+ | |||
| 231 | +1x |
-
+ 'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ', |
||
| 364 | -15x | +232 | +1x |
- lyt <- lyt %>%+ 'the "method" argument to `extract_rsp_subgroups()`. If method = "cmh", strata must also be specified via the ', |
| 365 | -15x | +233 | +1x |
- split_cols_by_multivar(+ '"variables" argument to `extract_rsp_subgroups()`.' |
| 366 | -15x | +|||
| 234 | +
- vars = rep(common_var, length(.stats)),+ ) |
|||
| 367 | -15x | +|||
| 235 | +
- varlabels = stat_labels,+ } |
|||
| 368 | -15x | +|||
| 236 | +
- extra_args = list(+ |
|||
| 369 | -15x | +|||
| 237 | +
- .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)),+ # Create "ci" column from "lcl" and "ucl" |
|||
| 370 | -15x | +238 | +13x |
- cache_env = replicate(length(.stats), list(env))+ df$or$ci <- combine_vectors(df$or$lcl, df$or$ucl) |
| 371 | +239 |
- )+ |
||
| 372 | +240 |
- )+ # Fill in missing formats with defaults+ |
+ ||
| 241 | +13x | +
+ default_fmts <- eval(formals(tabulate_rsp_subgroups)$.formats)+ |
+ ||
| 242 | +13x | +
+ .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]]) |
||
| 373 | +243 | |||
| 374 | -15x | +|||
| 244 | +
- if ("arm" %in% names(variables)) { # treatment effect
+ # Extract additional parameters from df |
|||
| 375 | +245 | 13x |
- lyt <- lyt %>%+ conf_level <- df$or$conf_level[1] |
|
| 376 | +246 | 13x |
- split_rows_by(+ method <- if ("pval_label" %in% names(df$or)) df$or$pval_label[1] else NULL
|
|
| 377 | +247 | 13x |
- common_var,+ colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method) |
|
| 378 | +248 | 13x |
- split_label = "Treatment:",+ prop_vars <- intersect(colvars$vars, c("n", "prop", "n_rsp"))
|
|
| 379 | +249 | 13x |
- label_pos = "visible",+ or_vars <- intersect(names(colvars$labels), c("n_tot", "or", "ci", "pval"))
|
|
| 380 | +250 | 13x |
- child_labels = "hidden",+ colvars_prop <- list(vars = prop_vars, labels = colvars$labels[prop_vars]) |
|
| 381 | +251 | 13x |
- section_div = head(.section_div, 1)+ colvars_or <- list(vars = or_vars, labels = colvars$labels[or_vars]) |
|
| 382 | +252 |
- )+ |
||
| 383 | +253 | 13x |
- if (!multivar) {
+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all) |
|
| 384 | -9x | +|||
| 254 | +
- lyt <- lyt %>%+ |
|||
| 385 | -9x | +|||
| 255 | +
- analyze_colvars(+ # Get analysis function for each statistic |
|||
| 386 | -9x | +256 | +13x |
- afun = a_coxreg,+ afun_lst <- a_response_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str) |
| 387 | -9x | +|||
| 257 | +
- na_str = na_str,+ |
|||
| 388 | -9x | +|||
| 258 | +
- extra_args = list(+ # Add risk difference column |
|||
| 389 | -9x | +259 | +13x |
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar,+ if (!is.null(riskdiff)) {
+ |
+
| 260 | +! | +
+ if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$prop$arm)[1]+ |
+ ||
| 261 | +! | +
+ if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$prop$arm)[2] |
||
| 390 | -9x | +262 | +1x |
- labelstr = ""+ colvars_or$vars <- c(colvars_or$vars, "riskdiff") |
| 391 | -+ | |||
| 263 | +1x |
- )+ colvars_or$labels <- c(colvars_or$labels, riskdiff = riskdiff$col_label) |
||
| 392 | -+ | |||
| 264 | +1x |
- )+ arm_cols <- paste(rep(c("n_rsp", "n_rsp", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
|
||
| 393 | +265 |
- } else { # treatment level effects
+
|
||
| 394 | -4x | +266 | +1x |
- lyt <- lyt %>%+ df_prop_diff <- df$prop %>% |
| 395 | -4x | +267 | +1x |
- summarize_row_groups(+ dplyr::select(-"prop") %>% |
| 396 | -4x | +268 | +1x |
- cfun = a_coxreg,+ tidyr::pivot_wider( |
| 397 | -4x | +269 | +1x |
- na_str = na_str,+ id_cols = c("subgroup", "var", "var_label", "row_type"),
|
| 398 | -4x | +270 | +1x |
- extra_args = list(+ names_from = "arm", |
| 399 | -4x | +271 | +1x |
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar+ values_from = c("n", "n_rsp")
|
| 400 | +272 |
- )+ ) %>% |
||
| 401 | -+ | |||
| 273 | +1x |
- ) %>%+ dplyr::rowwise() %>% |
||
| 402 | -4x | +274 | +1x |
- analyze_colvars(+ dplyr::mutate( |
| 403 | -4x | +275 | +1x |
- afun = a_coxreg,+ riskdiff = stat_propdiff_ci( |
| 404 | -4x | +276 | +1x |
- na_str = na_str,+ x = as.list(.data[[arm_cols[1]]]), |
| 405 | -4x | +277 | +1x |
- extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "")+ y = as.list(.data[[arm_cols[2]]]), |
| 406 | -+ | |||
| 278 | +1x |
- )+ N_x = .data[[arm_cols[3]]], |
||
| 407 | -+ | |||
| 279 | +1x |
- }+ N_y = .data[[arm_cols[4]]] |
||
| 408 | +280 |
- }+ ) |
||
| 409 | +281 | - - | -||
| 410 | -15x | -
- if ("covariates" %in% names(variables)) { # covariate main effects
- |
- ||
| 411 | -15x | -
- lyt <- lyt %>%+ ) %>% |
||
| 412 | -15x | +282 | +1x |
- split_rows_by_multivar(+ dplyr::select(-dplyr::all_of(arm_cols)) |
| 413 | -15x | +|||
| 283 | +
- vars = variables$covariates,+ |
|||
| 414 | -15x | +284 | +1x |
- varlabels = varlabels,+ df$or <- df$or %>% |
| 415 | -15x | +285 | +1x |
- split_label = "Covariate:",+ dplyr::left_join( |
| 416 | -15x | +286 | +1x |
- nested = FALSE,+ df_prop_diff, |
| 417 | -15x | +287 | +1x |
- child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ by = c("subgroup", "var", "var_label", "row_type")
|
| 418 | -15x | +|||
| 288 | +
- section_div = tail(.section_div, 1)+ ) |
|||
| 419 | +289 |
- )+ } |
||
| 420 | -15x | +|||
| 290 | +
- if (multivar || control$interaction || !"arm" %in% names(variables)) {
+
|
|||
| 421 | -11x | +|||
| 291 | +
- lyt <- lyt %>%+ # Add columns from table_prop (optional) |
|||
| 422 | -11x | +292 | +13x |
- summarize_row_groups(+ if (length(colvars_prop$vars) > 0) {
|
| 423 | -11x | +293 | +12x |
- cfun = a_coxreg,+ lyt_prop <- split_cols_by(lyt = lyt, var = "arm") |
| 424 | -11x | +294 | +12x |
- na_str = na_str,+ lyt_prop <- split_cols_by_multivar( |
| 425 | -11x | +295 | +12x |
- extra_args = list(+ lyt = lyt_prop, |
| 426 | -11x | +296 | +12x |
- variables = variables, at = at, control = control, multivar = multivar,+ vars = colvars_prop$vars, |
| 427 | -11x | +297 | +12x |
- var_main = if (multivar) multivar else control$interaction+ varlabels = colvars_prop$labels |
| 428 | +298 |
- )+ ) |
||
| 429 | +299 |
- )+ |
||
| 430 | +300 |
- } else {
+ # Add "All Patients" row |
||
| 431 | -1x | +301 | +12x |
- if (!is.null(varlabels)) names(varlabels) <- variables$covariates+ lyt_prop <- split_rows_by( |
| 432 | -4x | +302 | +12x |
- lyt <- lyt %>%+ lyt = lyt_prop, |
| 433 | -4x | +303 | +12x |
- analyze_colvars(+ var = "row_type", |
| 434 | -4x | +304 | +12x |
- afun = a_coxreg,+ split_fun = keep_split_levels("content"),
|
| 435 | -4x | +305 | +12x |
- na_str = na_str,+ nested = FALSE, |
| 436 | -4x | +306 | +12x |
- extra_args = list(+ child_labels = "hidden"+ |
+
| 307 | ++ |
+ ) |
||
| 437 | -4x | +308 | +12x |
- variables = variables, at = at, control = control, multivar = multivar,+ lyt_prop <- analyze_colvars( |
| 438 | -4x | +309 | +12x |
- var_main = if (multivar) multivar else control$interaction,+ lyt = lyt_prop, |
| 439 | -4x | +310 | +12x |
- labelstr = if (is.null(varlabels)) "" else varlabels+ afun = afun_lst[names(colvars_prop$labels)], |
| 440 | -+ | |||
| 311 | +12x |
- )+ na_str = na_str, |
||
| 441 | -+ | |||
| 312 | +12x |
- )+ extra_args = extra_args |
||
| 442 | +313 |
- }+ ) |
||
| 443 | +314 | |||
| 444 | -2x | +|||
| 315 | +
- if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm+ # Add analysis rows |
|||
| 445 | -15x | +316 | +12x |
- if (multivar || control$interaction) { # covariate level effects
+ if ("analysis" %in% df$prop$row_type) {
|
| 446 | +317 | 11x |
- lyt <- lyt %>%+ lyt_prop <- split_rows_by( |
|
| 447 | +318 | 11x |
- analyze_colvars(+ lyt = lyt_prop, |
|
| 448 | +319 | 11x |
- afun = a_coxreg,+ var = "row_type", |
|
| 449 | +320 | 11x |
- na_str = na_str,+ split_fun = keep_split_levels("analysis"),
|
|
| 450 | +321 | 11x |
- extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""),+ nested = FALSE, |
|
| 451 | +322 | 11x |
- indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L+ child_labels = "hidden" |
|
| 452 | +323 |
- )+ ) |
||
| 453 | -+ | |||
| 324 | +11x |
- }+ lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE) |
||
| 454 | -+ | |||
| 325 | +11x |
- }+ lyt_prop <- analyze_colvars( |
||
| 455 | -+ | |||
| 326 | +11x |
-
+ lyt = lyt_prop, |
||
| 456 | -15x | +327 | +11x |
- lyt+ afun = afun_lst[names(colvars_prop$labels)], |
| 457 | -+ | |||
| 328 | +11x |
- }+ na_str = na_str, |
| 1 | -+ | |||
| 329 | +11x |
- #' Horizontal waterfall plot+ inclNAs = TRUE, |
||
| 2 | -+ | |||
| 330 | +11x |
- #'+ extra_args = extra_args |
||
| 3 | +331 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 4 | +332 |
- #'+ } |
||
| 5 | +333 |
- #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup.+ |
||
| 6 | -+ | |||
| 334 | +12x |
- #'+ table_prop <- build_table(lyt_prop, df = df$prop) |
||
| 7 | +335 |
- #' @param height (`numeric`)\cr vector containing values to be plotted as the waterfall bars.+ } else {
|
||
| 8 | -+ | |||
| 336 | +1x |
- #' @param id (`character`)\cr vector containing identifiers to use as the x-axis label for the waterfall bars.+ table_prop <- NULL |
||
| 9 | +337 |
- #' @param col (`character`)\cr color(s).+ } |
||
| 10 | +338 |
- #' @param col_var (`factor`, `character`, or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.+ |
||
| 11 | +339 |
- #' @param xlab (`string`)\cr x label. Default is `"ID"`.+ # Add columns from table_or ("n_tot", "or", and "ci" required)
|
||
| 12 | -+ | |||
| 340 | +13x |
- #' @param ylab (`string`)\cr y label. Default is `"Value"`.+ lyt_or <- split_cols_by(lyt = lyt, var = "arm") |
||
| 13 | -+ | |||
| 341 | +13x |
- #' @param title (`string`)\cr text to be displayed as plot title.+ lyt_or <- split_cols_by_multivar( |
||
| 14 | -+ | |||
| 342 | +13x |
- #' @param col_legend_title (`string`)\cr text to be displayed as legend title.+ lyt = lyt_or, |
||
| 15 | -+ | |||
| 343 | +13x |
- #'+ vars = colvars_or$vars, |
||
| 16 | -+ | |||
| 344 | +13x |
- #' @return A `ggplot` waterfall plot.+ varlabels = colvars_or$labels |
||
| 17 | +345 |
- #'+ ) |
||
| 18 | +346 |
- #' @examples+ |
||
| 19 | +347 |
- #' library(dplyr)+ # Add "All Patients" row |
||
| 20 | -+ | |||
| 348 | +13x |
- #'+ lyt_or <- split_rows_by( |
||
| 21 | -+ | |||
| 349 | +13x |
- #' g_waterfall(height = c(3, 5, -1), id = letters[1:3])+ lyt = lyt_or, |
||
| 22 | -+ | |||
| 350 | +13x |
- #'+ var = "row_type", |
||
| 23 | -+ | |||
| 351 | +13x |
- #' g_waterfall(+ split_fun = keep_split_levels("content"),
|
||
| 24 | -+ | |||
| 352 | +13x |
- #' height = c(3, 5, -1),+ nested = FALSE, |
||
| 25 | -+ | |||
| 353 | +13x |
- #' id = letters[1:3],+ child_labels = "hidden" |
||
| 26 | +354 |
- #' col_var = letters[1:3]+ ) |
||
| 27 | -+ | |||
| 355 | +13x |
- #' )+ lyt_or <- analyze_colvars( |
||
| 28 | -+ | |||
| 356 | +13x |
- #'+ lyt = lyt_or, |
||
| 29 | -+ | |||
| 357 | +13x |
- #' adsl_f <- tern_ex_adsl %>%+ afun = afun_lst[names(colvars_or$labels)], |
||
| 30 | -+ | |||
| 358 | +13x |
- #' select(USUBJID, STUDYID, ARM, ARMCD, SEX)+ na_str = na_str, |
||
| 31 | -+ | |||
| 359 | +13x |
- #'+ extra_args = extra_args |
||
| 32 | +360 |
- #' adrs_f <- tern_ex_adrs %>%+ ) %>% |
||
| 33 | -+ | |||
| 361 | +13x |
- #' filter(PARAMCD == "OVRINV") %>%+ append_topleft("Baseline Risk Factors")
|
||
| 34 | +362 |
- #' mutate(pchg = rnorm(n(), 10, 50))+ |
||
| 35 | +363 |
- #'+ # Add analysis rows |
||
| 36 | -+ | |||
| 364 | +13x |
- #' adrs_f <- head(adrs_f, 30)+ if ("analysis" %in% df$or$row_type) {
|
||
| 37 | -+ | |||
| 365 | +12x |
- #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]+ lyt_or <- split_rows_by( |
||
| 38 | -+ | |||
| 366 | +12x |
- #' head(adrs_f)+ lyt = lyt_or, |
||
| 39 | -+ | |||
| 367 | +12x |
- #'+ var = "row_type", |
||
| 40 | -+ | |||
| 368 | +12x |
- #' g_waterfall(+ split_fun = keep_split_levels("analysis"),
|
||
| 41 | -+ | |||
| 369 | +12x |
- #' height = adrs_f$pchg,+ nested = FALSE, |
||
| 42 | -+ | |||
| 370 | +12x |
- #' id = adrs_f$USUBJID,+ child_labels = "hidden" |
||
| 43 | +371 |
- #' col_var = adrs_f$AVALC+ ) |
||
| 44 | -+ | |||
| 372 | +12x |
- #' )+ lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE) |
||
| 45 | -+ | |||
| 373 | +12x |
- #'+ lyt_or <- analyze_colvars( |
||
| 46 | -+ | |||
| 374 | +12x |
- #' g_waterfall(+ lyt = lyt_or, |
||
| 47 | -+ | |||
| 375 | +12x |
- #' height = adrs_f$pchg,+ afun = afun_lst[names(colvars_or$labels)], |
||
| 48 | -+ | |||
| 376 | +12x |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ na_str = na_str, |
||
| 49 | -+ | |||
| 377 | +12x |
- #' col_var = adrs_f$SEX+ inclNAs = TRUE, |
||
| 50 | -+ | |||
| 378 | +12x |
- #' )+ extra_args = extra_args |
||
| 51 | +379 |
- #'+ ) |
||
| 52 | +380 |
- #' g_waterfall(+ } |
||
| 53 | +381 |
- #' height = adrs_f$pchg,+ |
||
| 54 | -+ | |||
| 382 | +13x |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ table_or <- build_table(lyt_or, df = df$or) |
||
| 55 | +383 |
- #' xlab = "ID",+ |
||
| 56 | +384 |
- #' ylab = "Percentage Change",+ # Join tables, add forest plot attributes |
||
| 57 | -+ | |||
| 385 | +13x |
- #' title = "Waterfall plot"+ n_tot_id <- match("n_tot", colvars_or$vars)
|
||
| 58 | -+ | |||
| 386 | +13x |
- #' )+ if (is.null(table_prop)) {
|
||
| 59 | -+ | |||
| 387 | +1x |
- #'+ result <- table_or |
||
| 60 | -+ | |||
| 388 | +1x |
- #' @export+ or_id <- match("or", colvars_or$vars)
|
||
| 61 | -+ | |||
| 389 | +1x |
- g_waterfall <- function(height,+ ci_id <- match("ci", colvars_or$vars)
|
||
| 62 | +390 |
- id,+ } else {
|
||
| 63 | -+ | |||
| 391 | +12x |
- col_var = NULL,+ result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id]) |
||
| 64 | -+ | |||
| 392 | +12x |
- col = getOption("ggplot2.discrete.colour"),
+ or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
|
||
| 65 | -+ | |||
| 393 | +12x |
- xlab = NULL,+ ci_id <- 1L + ncol(table_prop) + match("ci", colvars_or$vars[-n_tot_id])
|
||
| 66 | -+ | |||
| 394 | +12x |
- ylab = NULL,+ n_tot_id <- 1L |
||
| 67 | +395 |
- col_legend_title = NULL,+ } |
||
| 68 | -+ | |||
| 396 | +13x |
- title = NULL) {
+ structure( |
||
| 69 | -2x | +397 | +13x |
- if (!is.null(col_var)) {
+ result, |
| 70 | -1x | +398 | +13x |
- check_same_n(height = height, id = id, col_var = col_var)+ forest_header = paste0(levels(df$prop$arm), "\nBetter"), |
| 71 | -+ | |||
| 399 | +13x |
- } else {
+ col_x = or_id, |
||
| 72 | -1x | +400 | +13x |
- check_same_n(height = height, id = id)+ col_ci = ci_id,+ |
+
| 401 | +13x | +
+ col_symbol_size = n_tot_id |
||
| 73 | +402 |
- }+ ) |
||
| 74 | +403 | ++ |
+ }+ |
+ |
| 404 | ||||
| 75 | -2x | +|||
| 405 | +
- checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
+ #' Labels for column variables in binary response by subgroup table |
|||
| 76 | -2x | +|||
| 406 | +
- checkmate::assert_character(col, null.ok = TRUE)+ #' |
|||
| 77 | +407 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 78 | -2x | +|||
| 408 | +
- xlabel <- deparse(substitute(id))+ #' |
|||
| 79 | -2x | +|||
| 409 | +
- ylabel <- deparse(substitute(height))+ #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels. |
|||
| 80 | +410 |
-
+ #' |
||
| 81 | -2x | +|||
| 411 | +
- col_label <- if (!missing(col_var)) {
+ #' @inheritParams argument_convention |
|||
| 82 | -1x | +|||
| 412 | +
- deparse(substitute(col_var))+ #' @inheritParams tabulate_rsp_subgroups |
|||
| 83 | +413 |
- }+ #' |
||
| 84 | +414 |
-
+ #' @return A `list` of variables to tabulate and their labels. |
||
| 85 | -2x | +|||
| 415 | +
- xlab <- if (is.null(xlab)) xlabel else xlab+ #' |
|||
| 86 | -2x | +|||
| 416 | +
- ylab <- if (is.null(ylab)) ylabel else ylab+ #' @export |
|||
| 87 | -2x | +|||
| 417 | +
- col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title+ d_rsp_subgroups_colvars <- function(vars, |
|||
| 88 | +418 |
-
+ conf_level = NULL,+ |
+ ||
| 419 | ++ |
+ method = NULL) {
|
||
| 89 | -2x | +420 | +22x |
- plot_data <- data.frame(+ checkmate::assert_character(vars) |
| 90 | -2x | +421 | +22x |
- height = height,+ checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
|
| 91 | -2x | +422 | +22x |
- id = as.character(id),+ checkmate::assert_subset( |
| 92 | -2x | +423 | +22x |
- col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),+ vars, |
| 93 | -2x | +424 | +22x |
- stringsAsFactors = FALSE+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
|
| 94 | +425 |
) |
||
| 95 | +426 | |||
| 96 | -2x | -
- plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]- |
- ||
| 97 | -+ | 427 | +22x |
-
+ varlabels <- c( |
| 98 | -2x | +428 | +22x |
- p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) ++ n = "n", |
| 99 | -2x | +429 | +22x |
- ggplot2::geom_col() ++ n_rsp = "Responders", |
| 100 | -2x | +430 | +22x |
- ggplot2::geom_text(+ prop = "Response (%)", |
| 101 | -2x | +431 | +22x |
- label = format(plot_data_ord$height, digits = 2),+ n_tot = "Total n", |
| 102 | -2x | +432 | +22x |
- vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)+ or = "Odds Ratio" |
| 103 | +433 |
- ) ++ ) |
||
| 104 | -2x | +434 | +22x |
- ggplot2::xlab(xlab) ++ colvars <- vars+ |
+
| 435 | ++ | + | ||
| 105 | -2x | +436 | +22x |
- ggplot2::ylab(ylab) ++ if ("ci" %in% colvars) {
|
| 106 | -2x | +437 | +22x |
- ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))+ checkmate::assert_false(is.null(conf_level)) |
| 107 | +438 | |||
| 108 | -2x | +439 | +22x |
- if (!is.null(col_var)) {
+ varlabels <- c( |
| 109 | -1x | +440 | +22x |
- p <- p ++ varlabels, |
| 110 | -1x | +441 | +22x |
- ggplot2::aes(fill = col_var) ++ ci = paste0(100 * conf_level, "% CI") |
| 111 | -1x | +|||
| 442 | +
- ggplot2::labs(fill = col_legend_title) ++ ) |
|||
| 112 | -1x | +|||
| 443 | +
- ggplot2::theme(+ |
|||
| 113 | -1x | +|||
| 444 | +
- legend.position = "bottom",+ # The `lcl`` variable is just a placeholder available in the analysis data, |
|||
| 114 | -1x | +|||
| 445 | +
- legend.background = ggplot2::element_blank(),+ # it is not acutally used in the tabulation. |
|||
| 115 | -1x | +|||
| 446 | +
- legend.title = ggplot2::element_text(face = "bold"),+ # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details. |
|||
| 116 | -1x | +447 | +22x |
- legend.box.background = ggplot2::element_rect(colour = "black")+ colvars[colvars == "ci"] <- "lcl" |
| 117 | +448 |
- )+ } |
||
| 118 | +449 |
- }+ |
||
| 119 | -+ | |||
| 450 | +22x |
-
+ if ("pval" %in% colvars) {
|
||
| 120 | -2x | +451 | +16x |
- if (!is.null(col)) {
+ varlabels <- c( |
| 121 | -1x | +452 | +16x |
- p <- p ++ varlabels, |
| 122 | -1x | +453 | +16x |
- ggplot2::scale_fill_manual(values = col)+ pval = method |
| 123 | +454 |
- }+ ) |
||
| 124 | +455 |
-
+ } |
||
| 125 | -2x | +|||
| 456 | +
- if (!is.null(title)) {
+
|
|||
| 126 | -1x | +457 | +22x |
- p <- p ++ list( |
| 127 | -1x | +458 | +22x |
- ggplot2::labs(title = title) ++ vars = colvars, |
| 128 | -1x | -
- ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))- |
- ||
| 129 | -+ | 459 | +22x |
- }+ labels = varlabels[vars] |
| 130 | +460 | - - | -||
| 131 | -2x | -
- p+ ) |
||
| 132 | +461 |
}@@ -97693,14 +95044,14 @@ tern coverage - 95.65% |
| 1 |
- #' Helper functions for subgroup treatment effect pattern (STEP) calculations+ #' Summarize analysis of covariance (ANCOVA) results |
||
| 5 |
- #' Helper functions that are used internally for the STEP calculations.+ #' The analyze function [summarize_ancova()] creates a layout element to summarize ANCOVA results. |
||
| 7 |
- #' @inheritParams argument_convention+ #' This function can be used to analyze multiple endpoints and/or multiple timepoints within the response variable(s) |
||
| 8 |
- #'+ #' specified as `vars`. |
||
| 9 |
- #' @name h_step+ #' |
||
| 10 |
- #' @include control_step.R+ #' Additional variables for the analysis, namely an arm (grouping) variable and covariate variables, can be defined |
||
| 11 |
- NULL+ #' via the `variables` argument. See below for more details on how to specify `variables`. An interaction term can |
||
| 12 |
-
+ #' be implemented in the model if needed. The interaction variable that should interact with the arm variable is |
||
| 13 |
- #' @describeIn h_step Creates the windows for STEP, based on the control settings+ #' specified via the `interaction_term` parameter, and the specific value of `interaction_term` for which to extract |
||
| 14 |
- #' provided.+ #' the ANCOVA results via the `interaction_y` parameter. |
||
| 16 |
- #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).+ #' @inheritParams h_ancova |
||
| 17 |
- #' @param control (named `list`)\cr output from `control_step()`.+ #' @inheritParams argument_convention |
||
| 18 |
- #'+ #' @param interaction_y (`string` or `flag`)\cr a selected item inside of the `interaction_item` variable which will be |
||
| 19 |
- #' @return+ #' used to select the specific ANCOVA results. if the interaction is not needed, the default option is `FALSE`. |
||
| 20 |
- #' * `h_step_window()` returns a list containing the window-selection matrix `sel`+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 21 |
- #' and the interval information matrix `interval`.+ #' |
||
| 22 |
- #'+ #' Options are: ``r shQuote(get_stats("summarize_ancova"))``
|
||
| 23 |
- #' @export+ #' |
||
| 24 |
- h_step_window <- function(x,+ #' @name summarize_ancova |
||
| 25 |
- control = control_step()) {
+ #' @order 1 |
||
| 26 | -12x | +
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ NULL |
|
| 27 | -12x | +
- checkmate::assert_list(control, names = "named")+ |
|
| 28 |
-
+ #' Helper function to return results of a linear model |
||
| 29 | -12x | +
- sel <- matrix(FALSE, length(x), control$num_points)+ #' |
|
| 30 | -12x | +
- out <- matrix(0, control$num_points, 3)+ #' @description `r lifecycle::badge("stable")`
|
|
| 31 | -12x | +
- colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
+ #' |
|
| 32 | -12x | +
- if (control$use_percentile) {
+ #' @inheritParams argument_convention |
|
| 33 |
- # Create windows according to percentile cutoffs.+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`. |
||
| 34 | -9x | +
- out <- cbind(out, out)+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with expected elements: |
|
| 35 | -9x | +
- colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
|
| 36 | -9x | +
- xs <- seq(0, 1, length.out = control$num_points + 2)[-1]+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
|
| 37 | -9x | +
- for (i in seq_len(control$num_points)) {
+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or |
|
| 38 | -185x | +
- out[i, 2:3] <- c(+ #' interaction terms indicated by `"X1 * X2"`. |
|
| 39 | -185x | +
- max(xs[i] - control$bandwidth, 0),+ #' @param interaction_item (`string` or `NULL`)\cr name of the variable that should have interactions |
|
| 40 | -185x | +
- min(xs[i] + control$bandwidth, 1)+ #' with arm. if the interaction is not needed, the default option is `NULL`. |
|
| 41 |
- )+ #' |
||
| 42 | -185x | +
- out[i, 5:6] <- stats::quantile(x, out[i, 2:3])+ #' @return The summary of a linear model. |
|
| 43 | -185x | +
- sel[, i] <- x >= out[i, 5] & x <= out[i, 6]+ #' |
|
| 44 |
- }+ #' @examples |
||
| 45 |
- # Center is the middle point of the percentile window.+ #' h_ancova( |
||
| 46 | -9x | +
- out[, 1] <- xs[-control$num_points - 1]+ #' .var = "Sepal.Length", |
|
| 47 | -9x | +
- out[, 4] <- stats::quantile(x, out[, 1])+ #' .df_row = iris, |
|
| 48 |
- } else {
+ #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
|
||
| 49 |
- # Create windows according to cutoffs.+ #' ) |
||
| 50 | -3x | +
- m <- c(min(x), max(x))+ #' |
|
| 51 | -3x | +
- xs <- seq(m[1], m[2], length.out = control$num_points + 2)[-1]+ #' @export |
|
| 52 | -3x | +
- for (i in seq_len(control$num_points)) {
+ h_ancova <- function(.var, |
|
| 53 | -11x | +
- out[i, 2:3] <- c(+ .df_row, |
|
| 54 | -11x | +
- max(xs[i] - control$bandwidth, m[1]),+ variables, |
|
| 55 | -11x | +
- min(xs[i] + control$bandwidth, m[2])+ interaction_item = NULL) {
|
|
| 56 | -+ | 27x |
- )+ checkmate::assert_string(.var) |
| 57 | -11x | +27x |
- sel[, i] <- x >= out[i, 2] & x <= out[i, 3]+ checkmate::assert_list(variables) |
| 58 | -+ | 27x |
- }+ checkmate::assert_subset(names(variables), c("arm", "covariates"))
|
| 59 | -+ | 27x |
- # Center is the same as the point for predicting.+ assert_df_with_variables(.df_row, list(rsp = .var)) |
| 60 | -3x | +
- out[, 1] <- xs[-control$num_points - 1]+ |
|
| 61 | -+ | 26x |
- }+ arm <- variables$arm |
| 62 | -12x | +26x |
- list(sel = sel, interval = out)+ covariates <- variables$covariates |
| 63 | -+ | 26x |
- }+ if (!is.null(covariates) && length(covariates) > 0) {
|
| 64 |
-
+ # Get all covariate variable names in the model. |
||
| 65 | -+ | 11x |
- #' @describeIn h_step Calculates the estimated treatment effect estimate+ var_list <- get_covariates(covariates) |
| 66 | -+ | 11x |
- #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted+ assert_df_with_variables(.df_row, var_list) |
| 67 |
- #' on `data` given `variables` specification, for a single biomarker value `x`.+ } |
||
| 68 |
- #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds+ |
||
| 69 | -+ | 25x |
- #' ratio estimates.+ covariates_part <- paste(covariates, collapse = " + ") |
| 70 | -+ | 25x |
- #'+ if (covariates_part != "") {
|
| 71 | -+ | 10x |
- #' @param model (`coxph` or `glm`)\cr the regression model object.+ formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm)) |
| 72 |
- #'+ } else {
|
||
| 73 | -+ | 15x |
- #' @return+ formula <- stats::as.formula(paste0(.var, " ~ ", arm)) |
| 74 |
- #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`.+ } |
||
| 75 |
- #'+ |
||
| 76 | -+ | 25x |
- #' @export+ if (is.null(interaction_item)) {
|
| 77 | -+ | 21x |
- h_step_trt_effect <- function(data,+ specs <- arm |
| 78 |
- model,+ } else {
|
||
| 79 | -+ | 4x |
- variables,+ specs <- c(arm, interaction_item) |
| 80 |
- x) {
+ } |
||
| 81 | -208x | +
- checkmate::assert_multi_class(model, c("coxph", "glm"))
+
|
|
| 82 | -208x | +25x |
- checkmate::assert_number(x)+ lm_fit <- stats::lm( |
| 83 | -208x | +25x |
- assert_df_with_variables(data, variables)+ formula = formula, |
| 84 | -208x | +25x |
- checkmate::assert_factor(data[[variables$arm]], n.levels = 2)+ data = .df_row |
| 85 |
-
+ ) |
||
| 86 | -208x | +25x |
- newdata <- data[c(1, 1), ]+ emmeans_fit <- emmeans::emmeans( |
| 87 | -208x | +25x |
- newdata[, variables$biomarker] <- x+ lm_fit, |
| 88 | -208x | +
- newdata[, variables$arm] <- levels(data[[variables$arm]])+ # Specify here the group variable over which EMM are desired. |
|
| 89 | -208x | +25x |
- model_terms <- stats::delete.response(stats::terms(model))+ specs = specs, |
| 90 | -208x | +
- model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels)+ # Pass the data again so that the factor levels of the arm variable can be inferred. |
|
| 91 | -208x | +25x |
- mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts)+ data = .df_row |
| 92 | -208x | +
- coefs <- stats::coef(model)+ ) |
|
| 93 |
- # Note: It is important to use the coef subset from matrix, otherwise intercept and+ |
||
| 94 | -+ | 25x |
- # strata are included for coxph() models.+ emmeans_fit |
| 95 | -208x | +
- mat <- mat[, names(coefs)]+ } |
|
| 96 | -208x | +
- mat_diff <- diff(mat)+ |
|
| 97 | -208x | +
- est <- mat_diff %*% coefs+ #' @describeIn summarize_ancova Statistics function that produces a named list of results |
|
| 98 | -208x | +
- var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff)+ #' of the investigated linear model. |
|
| 99 | -208x | +
- se <- sqrt(var)+ #' |
|
| 100 | -208x | +
- c(+ #' @return |
|
| 101 | -208x | +
- est = est,+ #' * `s_ancova()` returns a named list of 5 statistics: |
|
| 102 | -208x | +
- se = se+ #' * `n`: Count of complete sample size for the group. |
|
| 103 |
- )+ #' * `lsmean`: Estimated marginal means in the group. |
||
| 104 |
- }+ #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group. |
||
| 105 |
-
+ #' If working with the reference group, this will be empty. |
||
| 106 |
- #' @describeIn h_step Builds the model formula used in survival STEP calculations.+ #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison |
||
| 107 |
- #'+ #' to the reference group. |
||
| 108 |
- #' @return+ #' * `pval`: p-value (not adjusted for multiple comparisons). |
||
| 109 |
- #' * `h_step_survival_formula()` returns a model formula.+ #' |
||
| 110 |
- #'+ #' @keywords internal |
||
| 111 |
- #' @export+ s_ancova <- function(df, |
||
| 112 |
- h_step_survival_formula <- function(variables,+ .var, |
||
| 113 |
- control = control_step()) {
+ .df_row, |
||
| 114 | -10x | +
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ variables, |
|
| 115 |
-
+ .ref_group, |
||
| 116 | -10x | +
- assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
+ .in_ref_col, |
|
| 117 | -10x | +
- form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
+ conf_level, |
|
| 118 | -10x | +
- if (control$degree > 0) {
+ interaction_y = FALSE, |
|
| 119 | -5x | +
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ interaction_item = NULL) {
|
|
| 120 | -+ | 3x |
- }+ emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item) |
| 121 | -10x | +
- if (!is.null(variables$covariates)) {
+
|
|
| 122 | -6x | +3x |
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ sum_fit <- summary( |
| 123 | -+ | 3x |
- }+ emmeans_fit, |
| 124 | -10x | +3x |
- if (!is.null(variables$strata)) {
+ level = conf_level |
| 125 | -2x | +
- form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ ) |
|
| 126 |
- }+ |
||
| 127 | -10x | +3x |
- stats::as.formula(form)+ arm <- variables$arm |
| 128 |
- }+ |
||
| 129 | -+ | 3x |
-
+ sum_level <- as.character(unique(df[[arm]])) |
| 130 |
- #' @describeIn h_step Estimates the model with `formula` built based on+ |
||
| 131 |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ # Ensure that there is only one element in sum_level. |
||
| 132 | -+ | 3x |
- #' Cox regression.+ checkmate::assert_scalar(sum_level) |
| 133 |
- #'+ |
||
| 134 | -+ | 2x |
- #' @param formula (`formula`)\cr the regression model formula.+ sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ] |
| 135 |
- #' @param subset (`logical`)\cr subset vector.+ |
||
| 136 |
- #'+ # Get the index of the ref arm |
||
| 137 | -+ | 2x |
- #' @return+ if (interaction_y != FALSE) {
|
| 138 | -+ | 1x |
- #' * `h_step_survival_est()` returns a matrix of number of observations `n`,+ y <- unlist(df[(df[[interaction_item]] == interaction_y), .var]) |
| 139 |
- #' `events`, log hazard ratio estimates `loghr`, standard error `se`,+ # convert characters selected in interaction_y into the numeric order |
||
| 140 | -+ | 1x |
- #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is+ interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y) |
| 141 | -+ | 1x |
- #' included for each biomarker value in `x`.+ sum_fit_level <- sum_fit_level[interaction_y, ] |
| 142 |
- #'+ # if interaction is called, reset the index |
||
| 143 | -+ | 1x |
- #' @export+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
| 144 | -+ | 1x |
- h_step_survival_est <- function(formula,+ ref_key <- tail(ref_key, n = 1) |
| 145 | -+ | 1x |
- data,+ ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key |
| 146 |
- variables,+ } else {
|
||
| 147 | -+ | 1x |
- x,+ y <- df[[.var]] |
| 148 |
- subset = rep(TRUE, nrow(data)),+ # Get the index of the ref arm when interaction is not called |
||
| 149 | -+ | 1x |
- control = control_coxph()) {
+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
| 150 | -55x | +1x |
- checkmate::assert_formula(formula)+ ref_key <- tail(ref_key, n = 1) |
| 151 | -55x | +
- assert_df_with_variables(data, variables)+ } |
|
| 152 | -55x | +
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ |
|
| 153 | -55x | +2x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ if (.in_ref_col) {
|
| 154 | -55x | +1x |
- checkmate::assert_list(control, names = "named")+ list( |
| 155 | -+ | 1x |
-
+ n = length(y[!is.na(y)]), |
| 156 | -+ | 1x |
- # Note: `subset` in `coxph` needs to be an expression referring to `data` variables.+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"), |
| 157 | -55x | +1x |
- data$.subset <- subset+ lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"), |
| 158 | -55x | +1x |
- coxph_warnings <- NULL+ lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)), |
| 159 | -55x | +1x |
- tryCatch(+ pval = formatters::with_label(character(), "p-value") |
| 160 | -55x | +
- withCallingHandlers(+ ) |
|
| 161 | -55x | +
- expr = {
+ } else {
|
|
| 162 | -55x | +
- fit <- survival::coxph(+ # Estimate the differences between the marginal means. |
|
| 163 | -55x | +1x |
- formula = formula,+ emmeans_contrasts <- emmeans::contrast( |
| 164 | -55x | +1x |
- data = data,+ emmeans_fit, |
| 165 | -55x | +
- subset = .subset,+ # Compare all arms versus the control arm. |
|
| 166 | -55x | +1x |
- ties = control$ties+ method = "trt.vs.ctrl", |
| 167 |
- )+ # Take the arm factor from .ref_group as the control arm. |
||
| 168 | -+ | 1x |
- },+ ref = ref_key, |
| 169 | -55x | +1x |
- warning = function(w) {
+ level = conf_level |
| 170 | -1x | +
- coxph_warnings <<- c(coxph_warnings, w)+ ) |
|
| 171 | 1x |
- invokeRestart("muffleWarning")
+ sum_contrasts <- summary( |
|
| 172 | -+ | 1x |
- }+ emmeans_contrasts, |
| 173 |
- ),+ # Derive confidence intervals, t-tests and p-values. |
||
| 174 | -55x | +1x |
- finally = {
+ infer = TRUE, |
| 175 |
- }+ # Do not adjust the p-values for multiplicity. |
||
| 176 | -+ | 1x |
- )+ adjust = "none" |
| 177 | -55x | +
- if (!is.null(coxph_warnings)) {
+ ) |
|
| 178 | -1x | +
- warning(paste(+ |
|
| 179 | 1x |
- "Fit warnings occurred, please consider using a simpler model, or",+ contrast_lvls <- gsub( |
|
| 180 | 1x |
- "larger `bandwidth`, less `num_points` in `control_step()` settings"+ "^\\(|\\)$", "", gsub(paste0(" - \\(*", .ref_group[[arm]][1], ".*"), "", sum_contrasts$contrast)
|
|
| 181 |
- ))+ ) |
||
| 182 | -+ | 1x |
- }+ if (!is.null(interaction_item)) {
|
| 183 | -+ | ! |
- # Produce a matrix with one row per `x` and columns `est` and `se`.+ sum_contrasts_level <- sum_contrasts[grepl(sum_level, contrast_lvls, fixed = TRUE), ] |
| 184 | -55x | +
- estimates <- t(vapply(+ } else {
|
|
| 185 | -55x | +1x |
- X = x,+ sum_contrasts_level <- sum_contrasts[sum_level == contrast_lvls, ] |
| 186 | -55x | +
- FUN = h_step_trt_effect,+ } |
|
| 187 | -55x | +1x |
- FUN.VALUE = c(1, 2),+ if (interaction_y != FALSE) {
|
| 188 | -55x | +! |
- data = data,+ sum_contrasts_level <- sum_contrasts_level[interaction_y, ] |
| 189 | -55x | +
- model = fit,+ } |
|
| 190 | -55x | +
- variables = variables+ |
|
| 191 | -+ | 1x |
- ))+ list( |
| 192 | -55x | +1x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ n = length(y[!is.na(y)]), |
| 193 | -55x | +1x |
- cbind(+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"), |
| 194 | -55x | +1x |
- n = fit$n,+ lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"), |
| 195 | -55x | +1x |
- events = fit$nevent,+ lsmean_diff_ci = formatters::with_label( |
| 196 | -55x | +1x |
- loghr = estimates[, "est"],+ c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL), |
| 197 | -55x | +1x |
- se = estimates[, "se"],+ f_conf_level(conf_level) |
| 198 | -55x | +
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ ), |
|
| 199 | -55x | +1x |
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ pval = formatters::with_label(sum_contrasts_level$p.value, "p-value") |
| 200 |
- )+ ) |
||
| 201 |
- }+ } |
||
| 202 |
-
+ } |
||
| 203 |
- #' @describeIn h_step Builds the model formula used in response STEP calculations.+ |
||
| 204 |
- #'+ #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`. |
||
| 205 |
- #' @return+ #' |
||
| 206 |
- #' * `h_step_rsp_formula()` returns a model formula.+ #' @return |
||
| 207 |
- #'+ #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 208 |
- #' @export+ #' |
||
| 209 |
- h_step_rsp_formula <- function(variables,+ #' @keywords internal |
||
| 210 |
- control = c(control_step(), control_logistic())) {
+ a_ancova <- make_afun( |
||
| 211 | -14x | +
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ s_ancova, |
|
| 212 | -14x | +
- assert_list_of_variables(variables[c("arm", "biomarker", "response")])
+ .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
|
|
| 213 | -14x | +
- response_definition <- sub(+ .formats = c( |
|
| 214 | -14x | +
- pattern = "response",+ "n" = "xx", |
|
| 215 | -14x | +
- replacement = variables$response,+ "lsmean" = "xx.xx", |
|
| 216 | -14x | +
- x = control$response_definition,+ "lsmean_diff" = "xx.xx", |
|
| 217 | -14x | +
- fixed = TRUE+ "lsmean_diff_ci" = "(xx.xx, xx.xx)", |
|
| 218 |
- )+ "pval" = "x.xxxx | (<0.0001)" |
||
| 219 | -14x | +
- form <- paste0(response_definition, " ~ ", variables$arm)+ ), |
|
| 220 | -14x | +
- if (control$degree > 0) {
+ .null_ref_cells = FALSE |
|
| 221 | -8x | +
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ ) |
|
| 222 |
- }+ |
||
| 223 | -14x | +
- if (!is.null(variables$covariates)) {
+ #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments |
|
| 224 | -8x | +
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 225 |
- }+ #' |
||
| 226 | -14x | +
- if (!is.null(variables$strata)) {
+ #' @return |
|
| 227 | -5x | +
- strata_arg <- if (length(variables$strata) > 1) {
+ #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions, |
|
| 228 | -2x | +
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 229 |
- } else {
+ #' the statistics from `s_ancova()` to the table layout. |
||
| 230 | -3x | +
- variables$strata+ #' |
|
| 231 |
- }+ #' @examples |
||
| 232 | -5x | +
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ #' basic_table() %>% |
|
| 233 |
- }+ #' split_cols_by("Species", ref_group = "setosa") %>%
|
||
| 234 | -14x | +
- stats::as.formula(form)+ #' add_colcounts() %>% |
|
| 235 |
- }+ #' summarize_ancova( |
||
| 236 |
-
+ #' vars = "Petal.Length", |
||
| 237 |
- #' @describeIn h_step Estimates the model with `formula` built based on+ #' variables = list(arm = "Species", covariates = NULL), |
||
| 238 |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ #' table_names = "unadj", |
||
| 239 |
- #' logistic regression.+ #' conf_level = 0.95, var_labels = "Unadjusted comparison", |
||
| 240 |
- #'+ #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means") |
||
| 241 |
- #' @param formula (`formula`)\cr the regression model formula.+ #' ) %>% |
||
| 242 |
- #' @param subset (`logical`)\cr subset vector.+ #' summarize_ancova( |
||
| 243 |
- #'+ #' vars = "Petal.Length", |
||
| 244 |
- #' @return+ #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
|
||
| 245 |
- #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds+ #' table_names = "adj", |
||
| 246 |
- #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds+ #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)" |
||
| 247 |
- #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`.+ #' ) %>% |
||
| 248 |
- #'+ #' build_table(iris) |
||
| 249 |
- #' @export+ #' |
||
| 250 |
- h_step_rsp_est <- function(formula,+ #' @export |
||
| 251 |
- data,+ #' @order 2 |
||
| 252 |
- variables,+ summarize_ancova <- function(lyt, |
||
| 253 |
- x,+ vars, |
||
| 254 |
- subset = rep(TRUE, nrow(data)),+ variables, |
||
| 255 |
- control = control_logistic()) {
+ conf_level, |
||
| 256 | -58x | +
- checkmate::assert_formula(formula)+ interaction_y = FALSE, |
|
| 257 | -58x | +
- assert_df_with_variables(data, variables)+ interaction_item = NULL, |
|
| 258 | -58x | +
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ var_labels, |
|
| 259 | -58x | +
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ na_str = default_na_str(), |
|
| 260 | -58x | +
- checkmate::assert_list(control, names = "named")+ nested = TRUE, |
|
| 261 |
- # Note: `subset` in `glm` needs to be an expression referring to `data` variables.+ ..., |
||
| 262 | -58x | +
- data$.subset <- subset+ show_labels = "visible", |
|
| 263 | -58x | +
- fit_warnings <- NULL+ table_names = vars, |
|
| 264 | -58x | +
- tryCatch(+ .stats = NULL, |
|
| 265 | -58x | +
- withCallingHandlers(+ .formats = NULL, |
|
| 266 | -58x | +
- expr = {
+ .labels = NULL, |
|
| 267 | -58x | +
- fit <- if (is.null(variables$strata)) {
+ .indent_mods = NULL) {
|
|
| 268 | -54x | +7x |
- stats::glm(+ extra_args <- list( |
| 269 | -54x | +7x |
- formula = formula,+ variables = variables, conf_level = conf_level, interaction_y = interaction_y, |
| 270 | -54x | +7x |
- data = data,+ interaction_item = interaction_item, ... |
| 271 | -54x | +
- subset = .subset,+ ) |
|
| 272 | -54x | +
- family = stats::binomial("logit")
+
|
|
| 273 | -+ | 7x |
- )+ afun <- make_afun( |
| 274 | -+ | 7x |
- } else {
+ a_ancova, |
| 275 | -+ | 7x |
- # clogit needs coxph and strata imported+ interaction_y = interaction_y, |
| 276 | -4x | +7x |
- survival::clogit(+ interaction_item = interaction_item, |
| 277 | -4x | +7x |
- formula = formula,+ .stats = .stats, |
| 278 | -4x | +7x |
- data = data,+ .formats = .formats, |
| 279 | -4x | +7x |
- subset = .subset+ .labels = .labels, |
| 280 | -+ | 7x |
- )+ .indent_mods = .indent_mods |
| 281 |
- }+ ) |
||
| 282 |
- },+ |
||
| 283 | -58x | +7x |
- warning = function(w) {
+ analyze( |
| 284 | -19x | +7x |
- fit_warnings <<- c(fit_warnings, w)+ lyt, |
| 285 | -19x | +7x |
- invokeRestart("muffleWarning")
+ vars, |
| 286 | -+ | 7x |
- }+ var_labels = var_labels, |
| 287 | -+ | 7x |
- ),+ show_labels = show_labels, |
| 288 | -58x | +7x |
- finally = {
+ table_names = table_names, |
| 289 | -+ | 7x |
- }+ afun = afun, |
| 290 | -+ | 7x |
- )+ na_str = na_str, |
| 291 | -58x | +7x |
- if (!is.null(fit_warnings)) {
+ nested = nested, |
| 292 | -13x | -
- warning(paste(- |
- |
| 293 | -13x | -
- "Fit warnings occurred, please consider using a simpler model, or",- |
- |
| 294 | -13x | -
- "larger `bandwidth`, less `num_points` in `control_step()` settings"- |
- |
| 295 | -- |
- ))- |
- |
| 296 | -- |
- }- |
- |
| 297 | -- |
- # Produce a matrix with one row per `x` and columns `est` and `se`.- |
- |
| 298 | -58x | -
- estimates <- t(vapply(- |
- |
| 299 | -58x | -
- X = x,- |
- |
| 300 | -58x | -
- FUN = h_step_trt_effect,- |
- |
| 301 | -58x | -
- FUN.VALUE = c(1, 2),- |
- |
| 302 | -58x | -
- data = data,- |
- |
| 303 | -58x | -
- model = fit,- |
- |
| 304 | -58x | -
- variables = variables- |
- |
| 305 | -- |
- ))- |
- |
| 306 | -58x | -
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)- |
- |
| 307 | -58x | -
- cbind(- |
- |
| 308 | -58x | -
- n = length(fit$y),- |
- |
| 309 | -58x | -
- logor = estimates[, "est"],- |
- |
| 310 | -58x | -
- se = estimates[, "se"],- |
- |
| 311 | -58x | -
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],- |
- |
| 312 | -58x | +7x |
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ extra_args = extra_args |
| 313 | +293 |
) |
|
| 314 | +294 |
}@@ -99897,14 +97108,14 @@ tern coverage - 95.65% |
| 1 |
- #' Helper functions for Cox proportional hazards regression+ #' Univariate formula special term |
||
| 5 |
- #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ #' The special term `univariate` indicate that the model should be fitted individually for |
||
| 6 |
- #'+ #' every variable included in univariate. |
||
| 7 |
- #' @inheritParams argument_convention+ #' |
||
| 8 |
- #' @inheritParams h_coxreg_univar_extract+ #' @param x (`character`)\cr a vector of variable names separated by commas. |
||
| 9 |
- #' @inheritParams cox_regression_inter+ #' |
||
| 10 |
- #' @inheritParams control_coxreg+ #' @return When used within a model formula, produces univariate models for each variable provided. |
||
| 12 |
- #' @seealso [cox_regression]+ #' @details |
||
| 13 |
- #'+ #' If provided alongside with pairwise specification, the model |
||
| 14 |
- #' @name h_cox_regression+ #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models |
||
| 15 |
- NULL+ #' + `y ~ ARM` |
||
| 16 |
-
+ #' + `y ~ ARM + SEX` |
||
| 17 |
- #' @describeIn h_cox_regression Helper for Cox regression formula. Creates a list of formulas. It is used+ #' + `y ~ ARM + AGE` |
||
| 18 |
- #' internally by [fit_coxreg_univar()] for the comparison of univariate Cox regression models.+ #' + `y ~ ARM + RACE` |
||
| 20 |
- #' @return+ #' @export |
||
| 21 |
- #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]).+ univariate <- function(x) {
|
||
| 22 | -+ | 2x |
- #'+ structure(x, varname = deparse(substitute(x))) |
| 23 |
- #' @examples+ } |
||
| 24 |
- #' # `h_coxreg_univar_formulas`+ |
||
| 25 |
- #'+ # Get the right-hand-term of a formula |
||
| 26 |
- #' ## Simple formulas.+ rht <- function(x) {
|
||
| 27 | -+ | 4x |
- #' h_coxreg_univar_formulas(+ checkmate::assert_formula(x) |
| 28 | -+ | 4x |
- #' variables = list(+ y <- as.character(rev(x)[[1]]) |
| 29 | -+ | 4x |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
+ return(y) |
| 30 |
- #' )+ } |
||
| 31 |
- #' )+ |
||
| 32 |
- #'+ #' Hazard ratio estimation in interactions |
||
| 33 |
- #' ## Addition of an optional strata.+ #' |
||
| 34 |
- #' h_coxreg_univar_formulas(+ #' This function estimates the hazard ratios between arms when an interaction variable is given with |
||
| 35 |
- #' variables = list(+ #' specific values. |
||
| 36 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ #' |
||
| 37 |
- #' strata = "SITE"+ #' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of |
||
| 38 |
- #' )+ #' the levels of `variable` given the levels of `given`. |
||
| 39 |
- #' )+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels given by [levels()]. |
||
| 40 |
- #'+ #' @param mmat (named `numeric`) a vector filled with `0`s used as a template to obtain the design matrix. |
||
| 41 |
- #' ## Inclusion of the interaction term.+ #' @param coef (`numeric`)\cr vector of estimated coefficients. |
||
| 42 |
- #' h_coxreg_univar_formulas(+ #' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model. |
||
| 43 |
- #' variables = list(+ #' @param conf_level (`proportion`)\cr confidence level of estimate intervals. |
||
| 44 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ #' |
||
| 45 |
- #' strata = "SITE"+ #' @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 |
- #' interaction = TRUE+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 48 |
- #' )+ #' |
||
| 49 |
- #'+ #' - b1 (arm b), b2 (arm c) |
||
| 50 |
- #' ## Only covariates fitted in separate models.+ #' - b3 (sex m) |
||
| 51 |
- #' h_coxreg_univar_formulas(+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 52 |
- #' variables = list(+ #' |
||
| 53 |
- #' time = "time", event = "status", covariates = c("X", "y")
+ #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation |
||
| 54 |
- #' )+ #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5), |
||
| 55 |
- #' )+ #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained |
||
| 56 |
- #'+ #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95. |
||
| 57 |
- #' @export+ #' |
||
| 58 |
- h_coxreg_univar_formulas <- function(variables,+ #' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of |
||
| 59 |
- interaction = FALSE) {
+ #' `variable` and `given`, with columns: |
||
| 60 | -50x | +
- checkmate::assert_list(variables, names = "named")+ #' * `coef_hat`: Estimation of the coefficient. |
|
| 61 | -50x | +
- has_arm <- "arm" %in% names(variables)+ #' * `coef_se`: Standard error of the estimation. |
|
| 62 | -50x | +
- arm_name <- if (has_arm) "arm" else NULL+ #' * `hr`: Hazard ratio. |
|
| 63 |
-
+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
||
| 64 | -50x | +
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ #' |
|
| 65 |
-
+ #' @seealso [s_cox_multivariate()]. |
||
| 66 | -50x | +
- checkmate::assert_flag(interaction)+ #' |
|
| 67 |
-
+ #' @examples |
||
| 68 | -50x | +
- if (!has_arm || is.null(variables$covariates)) {
+ #' library(dplyr) |
|
| 69 | -10x | +
- checkmate::assert_false(interaction)+ #' library(survival) |
|
| 70 |
- }+ #' |
||
| 71 |
-
+ #' ADSL <- tern_ex_adsl %>% |
||
| 72 | -48x | +
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ #' filter(SEX %in% c("F", "M"))
|
|
| 73 |
-
+ #' |
||
| 74 | -48x | +
- if (!is.null(variables$covariates)) {
+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS") |
|
| 75 | -47x | +
- forms <- paste0(+ #' adtte$ARMCD <- droplevels(adtte$ARMCD) |
|
| 76 | -47x | +
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ #' adtte$SEX <- droplevels(adtte$SEX) |
|
| 77 | -47x | +
- ifelse(has_arm, variables$arm, "1"),+ #' |
|
| 78 | -47x | +
- ifelse(interaction, " * ", " + "),+ #' mod <- coxph( |
|
| 79 | -47x | +
- variables$covariates,+ #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2, |
|
| 80 | -47x | +
- ifelse(+ #' data = adtte |
|
| 81 | -47x | +
- !is.null(variables$strata),+ #' ) |
|
| 82 | -47x | +
- paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
+ #' |
|
| 83 |
- ""+ #' mmat <- stats::model.matrix(mod)[1, ] |
||
| 84 |
- )+ #' mmat[!mmat == 0] <- 0 |
||
| 85 |
- )+ #' |
||
| 86 |
- } else {
+ #' @keywords internal |
||
| 87 | -1x | +
- forms <- NULL+ estimate_coef <- function(variable, given, |
|
| 88 |
- }+ lvl_var, lvl_given, |
||
| 89 | -48x | +
- nams <- variables$covariates+ coef, |
|
| 90 | -48x | +
- if (has_arm) {
+ mmat, |
|
| 91 | -41x | +
- ref <- paste0(+ vcov, |
|
| 92 | -41x | +
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ conf_level = 0.95) {
|
|
| 93 | -41x | +8x |
- variables$arm,+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
| 94 | -41x | +8x |
- ifelse(+ giv_lvl <- paste0(given, lvl_given) |
| 95 | -41x | +
- !is.null(variables$strata),+ |
|
| 96 | -41x | +8x |
- paste0(+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
| 97 | -41x | +8x |
- " + strata(", paste0(variables$strata, collapse = ", "), ")"
+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 98 | -+ | 8x |
- ),+ design_mat <- within( |
| 99 | -+ | 8x |
- ""+ data = design_mat, |
| 100 | -+ | 8x |
- )+ expr = {
|
| 101 | -+ | 8x |
- )+ inter <- paste0(variable, ":", given) |
| 102 | -41x | +8x |
- forms <- c(ref, forms)+ rev_inter <- paste0(given, ":", variable) |
| 103 | -41x | +
- nams <- c("ref", nams)
+ } |
|
| 104 |
- }+ ) |
||
| 105 | -48x | +
- stats::setNames(forms, nams)+ |
|
| 106 | -+ | 8x |
- }+ split_by_variable <- design_mat$variable |
| 107 | -+ | 8x |
-
+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
| 108 |
- #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas+ |
||
| 109 | -+ | 8x |
- #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox+ design_mat <- apply( |
| 110 | -+ | 8x |
- #' regression models. Interactions will not be included in multivariate Cox regression model.+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
| 111 | -+ | 27x |
- #'+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
| 112 | -+ | 27x |
- #' @return+ return(mmat) |
| 113 |
- #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]).+ } |
||
| 114 |
- #'+ ) |
||
| 115 | -+ | 8x |
- #' @examples+ colnames(design_mat) <- interaction_names |
| 116 |
- #' # `h_coxreg_multivar_formula`+ |
||
| 117 | -+ | 8x |
- #'+ betas <- as.matrix(coef) |
| 118 |
- #' h_coxreg_multivar_formula(+ |
||
| 119 | -+ | 8x |
- #' variables = list(+ coef_hat <- t(design_mat) %*% betas |
| 120 | -+ | 8x |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
+ dimnames(coef_hat)[2] <- "coef" |
| 121 |
- #' )+ |
||
| 122 | -+ | 8x |
- #' )+ coef_se <- apply(design_mat, 2, function(x) {
|
| 123 | -+ | 27x |
- #'+ vcov_el <- as.logical(x) |
| 124 | -+ | 27x |
- #' # Addition of an optional strata.+ y <- vcov[vcov_el, vcov_el] |
| 125 | -+ | 27x |
- #' h_coxreg_multivar_formula(+ y <- sum(y) |
| 126 | -+ | 27x |
- #' variables = list(+ y <- sqrt(y) |
| 127 | -+ | 27x |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
+ return(y) |
| 128 |
- #' strata = "SITE"+ }) |
||
| 129 |
- #' )+ |
||
| 130 | -+ | 8x |
- #' )+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 131 | -+ | 8x |
- #'+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
| 132 |
- #' # Example without treatment arm.+ |
||
| 133 | -+ | 8x |
- #' h_coxreg_multivar_formula(+ y <- apply(y, 1, function(x) {
|
| 134 | -+ | 27x |
- #' variables = list(+ x["hr"] <- exp(x["coef"]) |
| 135 | -+ | 27x |
- #' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
| 136 | -+ | 27x |
- #' strata = "SITE"+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
| 137 |
- #' )+ |
||
| 138 | -+ | 27x |
- #' )+ return(x) |
| 139 |
- #'+ }) |
||
| 140 |
- #' @export+ |
||
| 141 | -+ | 8x |
- h_coxreg_multivar_formula <- function(variables) {
+ y <- t(y) |
| 142 | -89x | +8x |
- checkmate::assert_list(variables, names = "named")+ y <- by(y, split_by_variable, identity) |
| 143 | -89x | +8x |
- has_arm <- "arm" %in% names(variables)+ y <- lapply(y, as.matrix) |
| 144 | -89x | +
- arm_name <- if (has_arm) "arm" else NULL+ |
|
| 145 | -+ | 8x |
-
+ attr(y, "details") <- paste0( |
| 146 | -89x | +8x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ "Estimations of ", variable, |
| 147 | -+ | 8x |
-
+ " hazard ratio given the level of ", given, " compared to ", |
| 148 | -89x | +8x |
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ variable, " level ", lvl_var[1], "." |
| 149 |
-
+ ) |
||
| 150 | -89x | +8x |
- y <- paste0(+ return(y) |
| 151 | -89x | +
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ } |
|
| 152 | -89x | +
- ifelse(has_arm, variables$arm, "1")+ |
|
| 153 |
- )+ #' `tryCatch` around `car::Anova` |
||
| 154 | -89x | +
- if (length(variables$covariates) > 0) {
+ #' |
|
| 155 | -26x | +
- y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ")+ #' Captures warnings when executing [car::Anova]. |
|
| 156 |
- }+ #' |
||
| 157 | -89x | +
- if (!is.null(variables$strata)) {
+ #' @inheritParams car::Anova |
|
| 158 | -5x | +
- y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ #' |
|
| 159 |
- }+ #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings. |
||
| 160 | -89x | +
- y+ #' |
|
| 161 |
- }+ #' @examples |
||
| 162 |
-
+ #' # `car::Anova` on cox regression model including strata and expected |
||
| 163 |
- #' @describeIn h_cox_regression Utility function to help tabulate the result of+ #' # a likelihood ratio test triggers a warning as only Wald method is |
||
| 164 |
- #' a univariate Cox regression model.+ #' # accepted. |
||
| 166 |
- #' @param effect (`string`)\cr the treatment variable.+ #' library(survival) |
||
| 167 |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].+ #' |
||
| 168 |
- #'+ #' mod <- coxph( |
||
| 169 |
- #' @return+ #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps), |
||
| 170 |
- #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`,+ #' data = ovarian |
||
| 171 |
- #' `n`, `hr`, `lcl`, `ucl`, and `pval`.+ #' ) |
||
| 173 |
- #' @examples+ #' @keywords internal |
||
| 174 |
- #' library(survival)+ try_car_anova <- function(mod, |
||
| 175 |
- #'+ test.statistic) { # nolint
|
||
| 176 | -+ | 2x |
- #' dta_simple <- data.frame(+ y <- tryCatch( |
| 177 | -+ | 2x |
- #' time = c(5, 5, 10, 10, 5, 5, 10, 10),+ withCallingHandlers( |
| 178 | -+ | 2x |
- #' status = c(0, 0, 1, 0, 0, 1, 1, 1),+ expr = {
|
| 179 | -+ | 2x |
- #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
+ warn_text <- c() |
| 180 | -+ | 2x |
- #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75),+ list( |
| 181 | -+ | 2x |
- #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
+ aov = car::Anova( |
| 182 | -+ | 2x |
- #' )+ mod, |
| 183 | -+ | 2x |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ test.statistic = test.statistic, |
| 184 | -+ | 2x |
- #' result <- h_coxreg_univar_extract(+ type = "III" |
| 185 |
- #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple+ ), |
||
| 186 | -+ | 2x |
- #' )+ warn_text = warn_text |
| 187 |
- #' result+ ) |
||
| 188 |
- #'+ }, |
||
| 189 | -+ | 2x |
- #' @export+ warning = function(w) {
|
| 190 |
- h_coxreg_univar_extract <- function(effect,+ # If a warning is detected it is handled as "w". |
||
| 191 | -+ | ! |
- covar,+ warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
|
| 192 |
- data,+ |
||
| 193 |
- mod,+ # A warning is sometimes expected, then, we want to restart |
||
| 194 |
- control = control_coxreg()) {
+ # the execution while ignoring the warning. |
||
| 195 | -66x | +! |
- checkmate::assert_string(covar)+ invokeRestart("muffleWarning")
|
| 196 | -66x | +
- checkmate::assert_string(effect)+ } |
|
| 197 | -66x | +
- checkmate::assert_class(mod, "coxph")+ ), |
|
| 198 | -66x | +2x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ finally = {
|
| 199 |
-
+ } |
||
| 200 | -66x | +
- mod_aov <- muffled_car_anova(mod, test_statistic)+ ) |
|
| 201 | -66x | +
- msum <- summary(mod, conf.int = control$conf_level)+ |
|
| 202 | -66x | +2x |
- sum_cox <- broom::tidy(msum)+ return(y) |
| 203 |
-
+ } |
||
| 204 |
- # Combine results together.+ |
||
| 205 | -66x | +
- effect_aov <- mod_aov[effect, , drop = TRUE]+ #' Fit a Cox regression model and ANOVA |
|
| 206 | -66x | +
- pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]+ #' |
|
| 207 | -66x | +
- sum_main <- sum_cox[grepl(effect, sum_cox$level), ]+ #' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results. |
|
| 208 |
-
+ #' |
||
| 209 | -66x | +
- term_label <- if (effect == covar) {
+ #' @inheritParams t_coxreg |
|
| 210 | -34x | +
- paste0(+ #' |
|
| 211 | -34x | +
- levels(data[[covar]])[2],+ #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and |
|
| 212 | -34x | +
- " vs control (",
+ #' `aov` (result of [car::Anova()]). |
|
| 213 | -34x | +
- levels(data[[covar]])[1],+ #' |
|
| 214 |
- ")"+ #' @noRd |
||
| 215 |
- )+ fit_n_aov <- function(formula, |
||
| 216 |
- } else {
+ data = data, |
||
| 217 | -32x | +
- unname(labels_or_names(data[covar]))+ conf_level = conf_level, |
|
| 218 |
- }+ pval_method = c("wald", "likelihood"),
|
||
| 219 | -66x | +
- data.frame(+ ...) {
|
|
| 220 | -66x | +1x |
- effect = ifelse(covar == effect, "Treatment:", "Covariate:"),+ pval_method <- match.arg(pval_method) |
| 221 | -66x | +
- term = covar,+ |
|
| 222 | -66x | +1x |
- term_label = term_label,+ environment(formula) <- environment() |
| 223 | -66x | +1x |
- level = levels(data[[effect]])[2],+ suppressWarnings({
|
| 224 | -66x | +
- n = mod[["n"]],+ # We expect some warnings due to coxph which fails strict programming. |
|
| 225 | -66x | +1x |
- hr = unname(sum_main["exp(coef)"]),+ mod <- survival::coxph(formula, data = data, ...) |
| 226 | -66x | +1x |
- lcl = unname(sum_main[grep("lower", names(sum_main))]),
+ msum <- summary(mod, conf.int = conf_level) |
| 227 | -66x | +
- ucl = unname(sum_main[grep("upper", names(sum_main))]),
+ }) |
|
| 228 | -66x | +
- pval = pval,+ |
|
| 229 | -66x | +1x |
- stringsAsFactors = FALSE+ aov <- try_car_anova( |
| 230 | -+ | 1x |
- )+ mod, |
| 231 | -+ | 1x |
- }+ test.statistic = switch(pval_method, |
| 232 | -+ | 1x |
-
+ "wald" = "Wald", |
| 233 | -+ | 1x |
- #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help+ "likelihood" = "LR" |
| 234 |
- #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable.+ ) |
||
| 235 |
- #'+ ) |
||
| 236 |
- #' @return+ |
||
| 237 | -+ | 1x |
- #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`,+ warn_attr <- aov$warn_text |
| 238 | -+ | ! |
- #' `n`, `term`, and `term_label`.+ if (!is.null(aov$warn_text)) message(warn_attr) |
| 239 |
- #'+ |
||
| 240 | -+ | 1x |
- #' @examples+ aov <- aov$aov |
| 241 | -+ | 1x |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ y <- list(mod = mod, msum = msum, aov = aov) |
| 242 | -+ | 1x |
- #' result <- h_coxreg_multivar_extract(+ attr(y, "message") <- warn_attr |
| 243 |
- #' var = "var1", mod = mod, data = dta_simple+ |
||
| 244 | -+ | 1x |
- #' )+ return(y) |
| 245 |
- #' result+ } |
||
| 246 |
- #'+ |
||
| 247 |
- #' @export+ # argument_checks |
||
| 248 |
- h_coxreg_multivar_extract <- function(var,+ check_formula <- function(formula) {
|
||
| 249 | -+ | 1x |
- data,+ if (!(inherits(formula, "formula"))) {
|
| 250 | -+ | 1x |
- mod,+ stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
|
| 251 |
- control = control_coxreg()) {
+ } |
||
| 252 | -132x | +
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ |
|
| 253 | -132x | +! |
- mod_aov <- muffled_car_anova(mod, test_statistic)+ invisible() |
| 254 |
-
+ } |
||
| 255 | -132x | +
- msum <- summary(mod, conf.int = control$conf_level)+ |
|
| 256 | -132x | +
- sum_anova <- broom::tidy(mod_aov)+ check_covariate_formulas <- function(covariates) {
|
|
| 257 | -132x | +1x |
- sum_cox <- broom::tidy(msum)+ if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
|
| 258 | -+ | 1x |
-
+ stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
|
| 259 | -132x | +
- ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
+ } |
|
| 260 | -132x | +
- names(ret_anova)[2] <- "pval"+ |
|
| 261 | -132x | +! |
- if (is.factor(data[[var]])) {
+ invisible() |
| 262 | -53x | +
- ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ } |
|
| 263 |
- } else {
+
|
||
| 264 | -79x | +
- ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ name_covariate_names <- function(covariates) {
|
|
| 265 | -+ | 1x |
- }+ miss_names <- names(covariates) == "" |
| 266 | -132x | +1x |
- names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
+ no_names <- is.null(names(covariates)) |
| 267 | -132x | +! |
- varlab <- unname(labels_or_names(data[var]))+ if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name") |
| 268 | -132x | +! |
- ret_cox$term <- varlab+ if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
| 269 | -+ | 1x |
-
+ return(covariates) |
| 270 | -132x | +
- if (is.numeric(data[[var]])) {
+ } |
|
| 271 | -79x | +
- ret <- ret_cox+ |
|
| 272 | -79x | +
- ret$term_label <- ret$term+ check_increments <- function(increments, covariates) {
|
|
| 273 | -53x | +1x |
- } else if (length(levels(data[[var]])) <= 2) {
+ if (!is.null(increments)) {
|
| 274 | -34x | +1x |
- ret_anova$pval <- NA+ covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
| 275 | -34x | +1x |
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ lapply( |
| 276 | -34x | +1x |
- ret_cox$level <- gsub(var, "", ret_cox$level)+ X = names(increments), FUN = function(x) {
|
| 277 | -34x | +3x |
- ret_cox$term_label <- ret_cox$level+ if (!x %in% covariates) {
|
| 278 | -34x | +1x |
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ warning( |
| 279 | -+ | 1x |
- } else {
+ paste( |
| 280 | -19x | +1x |
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ "Check `increments`, the `increment` for ", x, |
| 281 | -19x | +1x |
- ret_cox$level <- gsub(var, "", ret_cox$level)+ "doesn't match any names in investigated covariate(s)." |
| 282 | -19x | +
- ret_cox$term_label <- ret_cox$level+ ) |
|
| 283 | -19x | +
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ ) |
|
| 284 |
- }+ } |
||
| 285 |
-
+ } |
||
| 286 | -132x | +
- as.data.frame(ret)+ ) |
|
| 287 |
- }+ } |
| 1 | +288 |
- #' Occurrence table pruning+ |
||
| 2 | -+ | |||
| 289 | +1x |
- #'+ invisible() |
||
| 3 | +290 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +291 |
- #'+ |
||
| 5 | +292 |
- #' Family of constructor and condition functions to flexibly prune occurrence tables.+ #' Multivariate Cox model - summarized results |
||
| 6 | +293 |
- #' The condition functions always return whether the row result is higher than the threshold.+ #' |
||
| 7 | +294 |
- #' Since they are of class [CombinationFunction()] they can be logically combined with other condition+ #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or |
||
| 8 | +295 |
- #' functions.+ #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually |
||
| 9 | +296 |
- #'+ #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the |
||
| 10 | +297 |
- #' @note Since most table specifications are worded positively, we name our constructor and condition+ #' covariates included in the model. |
||
| 11 | +298 |
- #' functions positively, too. However, note that the result of [keep_rows()] says what+ #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the |
||
| 12 | +299 |
- #' should be pruned, to conform with the [rtables::prune_table()] interface.+ #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis, |
||
| 13 | +300 |
- #'+ #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**, |
||
| 14 | +301 |
- #' @examples+ #' `NEST's bookdown`) |
||
| 15 | +302 |
- #' \donttest{
+ #' |
||
| 16 | +303 |
- #' tab <- basic_table() %>%+ #' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model |
||
| 17 | +304 |
- #' split_cols_by("ARM") %>%
+ #' including covariates. |
||
| 18 | +305 |
- #' split_rows_by("RACE") %>%
+ #' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates. |
||
| 19 | +306 |
- #' split_rows_by("STRATA1") %>%
+ #' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95. |
||
| 20 | +307 |
- #' summarize_row_groups() %>%+ #' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of |
||
| 21 | +308 |
- #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
+ #' `"wald"` (default) or `"likelihood"`. |
||
| 22 | +309 |
- #' build_table(DM)+ #' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the |
||
| 23 | +310 |
- #' }+ #' method for tie handling, one of `exact` (default), `efron`, `breslow`. |
||
| 24 | +311 |
#' |
||
| 25 | +312 |
- #' @name prune_occurrences+ #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`. |
||
| 26 | +313 |
- NULL+ #' |
||
| 27 | +314 |
-
+ #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms |
||
| 28 | +315 |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ #' but is out of scope as defined by the Global Data Standards Repository |
||
| 29 | +316 |
- #' a row condition function. This removes all analysis rows (`TableRow`) that should be+ #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**). |
||
| 30 | +317 |
- #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no+ #' |
||
| 31 | +318 |
- #' children left.+ #' @seealso [estimate_coef()]. |
||
| 32 | +319 |
#' |
||
| 33 | +320 |
- #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual+ #' @examples |
||
| 34 | +321 |
- #' analysis rows and flags whether these should be kept in the pruned table.+ #' library(dplyr) |
||
| 35 | +322 |
#' |
||
| 36 | +323 |
- #' @return+ #' adtte <- tern_ex_adtte |
||
| 37 | +324 |
- #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()]+ #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered |
||
| 38 | +325 |
- #' to prune an `rtables` table.+ #' adtte_f <- filter( |
||
| 39 | +326 |
- #'+ #' adtte_f, |
||
| 40 | +327 |
- #' @examples+ #' PARAMCD == "OS" & |
||
| 41 | +328 |
- #' \donttest{
+ #' SEX %in% c("F", "M") &
|
||
| 42 | +329 |
- #' # `keep_rows`+ #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
|
||
| 43 | +330 |
- #' is_non_empty <- !CombinationFunction(all_zero_or_na)+ #' ) |
||
| 44 | +331 |
- #' prune_table(tab, keep_rows(is_non_empty))+ #' adtte_f$SEX <- droplevels(adtte_f$SEX) |
||
| 45 | +332 |
- #' }+ #' adtte_f$RACE <- droplevels(adtte_f$RACE) |
||
| 46 | +333 |
#' |
||
| 47 | +334 |
- #' @export+ #' @keywords internal |
||
| 48 | +335 |
- keep_rows <- function(row_condition) {
+ s_cox_multivariate <- function(formula, data, |
||
| 49 | -6x | +|||
| 336 | +
- checkmate::assert_function(row_condition)+ conf_level = 0.95,+ |
+ |||
| 337 | ++ |
+ pval_method = c("wald", "likelihood"),
+ |
+ ||
| 338 | ++ |
+ ...) {
|
||
| 50 | -6x | +339 | +1x |
- function(table_tree) {
+ tf <- stats::terms(formula, specials = c("strata"))
|
| 51 | -2256x | +340 | +1x |
- if (inherits(table_tree, "TableRow")) {
+ covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))] |
| 52 | -1872x | +341 | +1x |
- return(!row_condition(table_tree))+ lapply( |
| 53 | -+ | |||
| 342 | +1x |
- }+ X = covariates, |
||
| 54 | -384x | +343 | +1x |
- children <- tree_children(table_tree)+ FUN = function(x) {
|
| 55 | -384x | +344 | +3x |
- identical(length(children), 0L)+ if (is.character(data[[x]])) {
|
| 56 | -+ | |||
| 345 | +1x |
- }+ data[[x]] <<- as.factor(data[[x]]) |
||
| 57 | +346 |
- }+ } |
||
| 58 | -+ | |||
| 347 | +3x |
-
+ invisible() |
||
| 59 | +348 |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ } |
||
| 60 | +349 |
- #' a condition for the (first) content row in leaf tables. This removes all leaf tables where+ ) |
||
| 61 | -+ | |||
| 350 | +1x |
- #' the first content row does not fulfill the condition. It does not check individual rows.+ pval_method <- match.arg(pval_method) |
||
| 62 | +351 |
- #' It then proceeds recursively by removing the sub tree if there are no children left.+ |
||
| 63 | +352 |
- #'+ # Results directly exported from environment(fit_n_aov) to environment(s_function_draft) |
||
| 64 | -+ | |||
| 353 | +1x |
- #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual+ y <- fit_n_aov( |
||
| 65 | -+ | |||
| 354 | +1x |
- #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.+ formula = formula, |
||
| 66 | -+ | |||
| 355 | +1x |
- #'+ data = data, |
||
| 67 | -+ | |||
| 356 | +1x |
- #' @return+ conf_level = conf_level, |
||
| 68 | -+ | |||
| 357 | +1x |
- #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content+ pval_method = pval_method, |
||
| 69 | +358 |
- #' row of leaf tables in the table.+ ... |
||
| 70 | +359 |
- #'+ ) |
||
| 71 | -+ | |||
| 360 | +1x |
- #' @examples+ mod <- y$mod |
||
| 72 | -+ | |||
| 361 | +1x |
- #' # `keep_content_rows`+ aov <- y$aov |
||
| 73 | -+ | |||
| 362 | +1x |
- #' \donttest{
+ msum <- y$msum |
||
| 74 | -+ | |||
| 363 | +1x |
- #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))+ list2env(as.list(y), environment()) |
||
| 75 | +364 |
- #' prune_table(tab, keep_content_rows(more_than_twenty))+ |
||
| 76 | -+ | |||
| 365 | +1x |
- #' }+ all_term_labs <- attr(mod$terms, "term.labels") |
||
| 77 | -+ | |||
| 366 | +1x |
- #'+ term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)] |
||
| 78 | -+ | |||
| 367 | +1x |
- #' @export+ names(term_labs) <- term_labs |
||
| 79 | +368 |
- keep_content_rows <- function(content_row_condition) {
+
|
||
| 80 | +369 | 1x |
- checkmate::assert_function(content_row_condition)+ coef_inter <- NULL |
|
| 81 | +370 | 1x |
- function(table_tree) {
+ if (any(attr(mod$terms, "order") > 1)) {
|
|
| 82 | -166x | +371 | +1x |
- if (is_leaf_table(table_tree)) {
+ for_inter <- all_term_labs[attr(mod$terms, "order") > 1] |
| 83 | -24x | +372 | +1x |
- content_row <- h_content_first_row(table_tree)+ names(for_inter) <- for_inter |
| 84 | -24x | +373 | +1x |
- return(!content_row_condition(content_row))+ mmat <- stats::model.matrix(mod)[1, ] |
| 85 | -+ | |||
| 374 | +1x |
- }+ mmat[!mmat == 0] <- 0 |
||
| 86 | -142x | +375 | +1x |
- if (inherits(table_tree, "DataRow")) {
+ mcoef <- stats::coef(mod) |
| 87 | -120x | +376 | +1x |
- return(FALSE)+ mvcov <- stats::vcov(mod) |
| 88 | +377 |
- }+ |
||
| 89 | -22x | +378 | +1x |
- children <- tree_children(table_tree)+ estimate_coef_local <- function(variable, given) {
|
| 90 | -22x | +379 | +6x |
- identical(length(children), 0L)+ estimate_coef( |
| 91 | -+ | |||
| 380 | +6x |
- }+ variable, given, |
||
| 92 | -+ | |||
| 381 | +6x |
- }+ coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level, |
||
| 93 | -+ | |||
| 382 | +6x |
-
+ lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]]) |
||
| 94 | +383 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns.+ ) |
||
| 95 | +384 |
- #'+ } |
||
| 96 | +385 |
- #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row.+ |
||
| 97 | -+ | |||
| 386 | +1x |
- #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including+ coef_inter <- lapply( |
||
| 98 | -+ | |||
| 387 | +1x |
- #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices+ for_inter, function(x) {
|
||
| 99 | -+ | |||
| 388 | +3x |
- #' directly instead.+ y <- attr(mod$terms, "factors")[, x] |
||
| 100 | -+ | |||
| 389 | +3x |
- #'+ y <- names(y[y > 0]) |
||
| 101 | -+ | |||
| 390 | +3x |
- #' @return+ Map(estimate_coef_local, variable = y, given = rev(y)) |
||
| 102 | +391 |
- #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column.+ } |
||
| 103 | +392 |
- #'+ ) |
||
| 104 | +393 |
- #' @examples+ } |
||
| 105 | +394 |
- #' \donttest{
+
|
||
| 106 | -+ | |||
| 395 | +1x |
- #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))+ list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter) |
||
| 107 | +396 |
- #' prune_table(tab, keep_rows(more_than_one))+ } |
| 108 | +1 |
- #' }+ #' Cox regression helper function for interactions |
||
| 109 | +2 |
#' |
||
| 110 | +3 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 111 | +4 |
- has_count_in_cols <- function(atleast, ...) {
- |
- ||
| 112 | -6x | -
- checkmate::assert_count(atleast)- |
- ||
| 113 | -6x | -
- CombinationFunction(function(table_row) {
- |
- ||
| 114 | -337x | -
- row_counts <- h_row_counts(table_row, ...)- |
- ||
| 115 | -337x | -
- total_count <- sum(row_counts)+ #' |
||
| 116 | -337x | +|||
| 5 | +
- total_count >= atleast+ #' Test and estimate the effect of a treatment in interaction with a covariate. |
|||
| 117 | +6 |
- })+ #' The effect is estimated as the HR of the tested treatment for a given level |
||
| 118 | +7 |
- }+ #' of the covariate, in comparison to the treatment control. |
||
| 119 | +8 |
-
+ #' |
||
| 120 | +9 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in+ #' @inheritParams argument_convention |
||
| 121 | +10 |
- #' the specified columns satisfying a threshold.+ #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested. |
||
| 122 | +11 |
- #'+ #' @param effect (`string`)\cr the name of the effect to be tested and estimated. |
||
| 123 | +12 |
- #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row.+ #' @param covar (`string`)\cr the name of the covariate in the model. |
||
| 124 | +13 |
- #'+ #' @param mod (`coxph`)\cr the Cox regression model. |
||
| 125 | +14 |
- #' @return+ #' @param label (`string`)\cr the label to be returned as `term_label`. |
||
| 126 | +15 |
- #' * `has_count_in_any_col()` returns a condition function that compares the counts in the+ #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()]. |
||
| 127 | +16 |
- #' specified columns with the threshold.+ #' @param ... see methods. |
||
| 128 | +17 |
#' |
||
| 129 | +18 |
#' @examples |
||
| 130 | +19 |
- #' \donttest{
+ #' library(survival) |
||
| 131 | +20 |
- #' # `has_count_in_any_col`+ #' |
||
| 132 | +21 |
- #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 133 | +22 |
- #' prune_table(tab, keep_rows(any_more_than_one))+ #' |
||
| 134 | +23 |
- #' }+ #' # Testing dataset [survival::bladder]. |
||
| 135 | +24 |
- #'+ #' dta_bladder <- with( |
||
| 136 | +25 |
- #' @export+ #' data = bladder[bladder$enum < 5, ], |
||
| 137 | +26 |
- has_count_in_any_col <- function(atleast, ...) {
- |
- ||
| 138 | -3x | -
- checkmate::assert_count(atleast)- |
- ||
| 139 | -3x | -
- CombinationFunction(function(table_row) {
- |
- ||
| 140 | -3x | -
- row_counts <- h_row_counts(table_row, ...)- |
- ||
| 141 | -3x | -
- any(row_counts >= atleast)+ #' data.frame( |
||
| 142 | +27 |
- })+ #' time = stop, |
||
| 143 | +28 |
- }+ #' status = event, |
||
| 144 | +29 |
-
+ #' armcd = as.factor(rx), |
||
| 145 | +30 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in+ #' covar1 = as.factor(enum), |
||
| 146 | +31 |
- #' the specified columns.+ #' covar2 = factor( |
||
| 147 | +32 |
- #'+ #' sample(as.factor(enum)), |
||
| 148 | +33 |
- #' @return+ #' levels = 1:4, |
||
| 149 | +34 |
- #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the+ #' labels = c("F", "F", "M", "M")
|
||
| 150 | +35 |
- #' specified column, and computes the fraction by dividing by the total column counts.+ #' ) |
||
| 151 | +36 |
- #'+ #' ) |
||
| 152 | +37 |
- #' @examples+ #' ) |
||
| 153 | +38 |
- #' \donttest{
+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 154 | +39 |
- #' # `has_fraction_in_cols`+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 155 | +40 |
- #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 156 | +41 |
- #' prune_table(tab, keep_rows(more_than_five_percent))+ #' |
||
| 157 | +42 |
- #' }+ #' plot( |
||
| 158 | +43 |
- #'+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
||
| 159 | +44 |
- #' @export+ #' lty = 2:4, |
||
| 160 | +45 |
- has_fraction_in_cols <- function(atleast, ...) {
- |
- ||
| 161 | -4x | -
- assert_proportion_value(atleast, include_boundaries = TRUE)- |
- ||
| 162 | -4x | -
- CombinationFunction(function(table_row) {
- |
- ||
| 163 | -306x | -
- row_counts <- h_row_counts(table_row, ...)- |
- ||
| 164 | -306x | -
- total_count <- sum(row_counts)- |
- ||
| 165 | -306x | -
- col_counts <- h_col_counts(table_row, ...)- |
- ||
| 166 | -306x | -
- total_n <- sum(col_counts)+ #' xlab = "Months", |
||
| 167 | -306x | +|||
| 46 | +
- total_percent <- total_count / total_n+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
|||
| 168 | -306x | +|||
| 47 | +
- total_percent >= atleast+ #' ) |
|||
| 169 | +48 |
- })+ #' |
||
| 170 | +49 |
- }+ #' @name cox_regression_inter |
||
| 171 | +50 |
-
+ NULL |
||
| 172 | +51 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in+ |
||
| 173 | +52 |
- #' the specified columns.+ #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect. |
||
| 174 | +53 |
#' |
||
| 175 | +54 |
#' @return |
||
| 176 | +55 |
- #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions+ #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following |
||
| 177 | +56 |
- #' in the specified columns and checks whether any of them fulfill the threshold.+ #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`. |
||
| 178 | +57 |
#' |
||
| 179 | -- |
- #' @examples- |
- ||
| 180 | +58 |
- #' \donttest{
+ #' @export |
||
| 181 | +59 |
- #' # `has_fraction_in_any_col`+ h_coxreg_inter_effect <- function(x, |
||
| 182 | +60 |
- #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))+ effect, |
||
| 183 | +61 |
- #' prune_table(tab, keep_rows(any_atleast_five_percent))+ covar, |
||
| 184 | +62 |
- #' }+ mod, |
||
| 185 | +63 |
- #'+ label, |
||
| 186 | +64 |
- #' @export+ control, |
||
| 187 | +65 |
- has_fraction_in_any_col <- function(atleast, ...) {
- |
- ||
| 188 | -3x | -
- assert_proportion_value(atleast, include_boundaries = TRUE)- |
- ||
| 189 | -3x | -
- CombinationFunction(function(table_row) {
- |
- ||
| 190 | -3x | -
- row_fractions <- h_row_fractions(table_row, ...)+ ...) {
|
||
| 191 | -3x | -
- any(row_fractions >= atleast)- |
- ||
| 192 | -+ | 66 | +29x |
- })+ UseMethod("h_coxreg_inter_effect", x)
|
| 193 | +67 |
} |
||
| 194 | +68 | |||
| 195 | +69 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate. |
||
| 196 | +70 |
- #' between the fractions reported in each specified column.+ #' |
||
| 197 | +71 |
- #'+ #' @method h_coxreg_inter_effect numeric |
||
| 198 | +72 |
- #' @return+ #' |
||
| 199 | +73 |
- #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each+ #' @param at (`list`)\cr a list with items named after the covariate, every |
||
| 200 | +74 |
- #' specified column, and computes the difference of the minimum and maximum.+ #' item is a vector of levels at which the interaction should be estimated. |
||
| 201 | +75 |
#' |
||
| 202 | +76 |
- #' @examples+ #' @export |
||
| 203 | +77 |
- #' \donttest{
+ h_coxreg_inter_effect.numeric <- function(x, |
||
| 204 | +78 |
- #' # `has_fractions_difference`+ effect, |
||
| 205 | +79 |
- #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))+ covar, |
||
| 206 | +80 |
- #' prune_table(tab, keep_rows(more_than_five_percent_diff))+ mod, |
||
| 207 | +81 |
- #' }+ label, |
||
| 208 | +82 |
- #'+ control, |
||
| 209 | +83 |
- #' @export+ at, |
||
| 210 | +84 |
- has_fractions_difference <- function(atleast, ...) {
+ ...) {
|
||
| 211 | -4x | +85 | +7x |
- assert_proportion_value(atleast, include_boundaries = TRUE)+ betas <- stats::coef(mod) |
| 212 | -4x | +86 | +7x |
- CombinationFunction(function(table_row) {
+ attrs <- attr(stats::terms(mod), "term.labels") |
| 213 | -246x | +87 | +7x |
- fractions <- h_row_fractions(table_row, ...)+ term_indices <- grep( |
| 214 | -246x | +88 | +7x |
- difference <- diff(range(fractions))+ pattern = effect, |
| 215 | -246x | +89 | +7x |
- difference >= atleast+ x = attrs[!grepl("strata\\(", attrs)]
|
| 216 | +90 |
- })+ ) |
||
| 217 | -+ | |||
| 91 | +7x |
- }+ checkmate::assert_vector(term_indices, len = 2) |
||
| 218 | -+ | |||
| 92 | +7x |
-
+ betas <- betas[term_indices] |
||
| 219 | -+ | |||
| 93 | +7x |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ betas_var <- diag(stats::vcov(mod))[term_indices] |
||
| 220 | -+ | |||
| 94 | +7x |
- #' between the counts reported in each specified column.+ betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]] |
||
| 221 | -+ | |||
| 95 | +7x |
- #'+ xval <- if (is.null(at[[covar]])) {
|
||
| 222 | -+ | |||
| 96 | +6x |
- #' @return+ stats::median(x) |
||
| 223 | +97 |
- #' * `has_counts_difference()` returns a condition function that extracts the counts of each+ } else {
|
||
| 224 | -+ | |||
| 98 | +1x |
- #' specified column, and computes the difference of the minimum and maximum.+ at[[covar]] |
||
| 225 | +99 |
- #'+ } |
||
| 226 | -+ | |||
| 100 | +7x |
- #' @examples+ effect_index <- !grepl(covar, names(betas)) |
||
| 227 | -+ | |||
| 101 | +7x |
- #' \donttest{
+ coef_hat <- betas[effect_index] + xval * betas[!effect_index] |
||
| 228 | -+ | |||
| 102 | +7x |
- #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))+ coef_se <- sqrt( |
||
| 229 | -+ | |||
| 103 | +7x |
- #' prune_table(tab, keep_rows(more_than_one_diff))+ betas_var[effect_index] + |
||
| 230 | -+ | |||
| 104 | +7x |
- #' }+ xval ^ 2 * betas_var[!effect_index] + # styler: off |
||
| 231 | -+ | |||
| 105 | +7x |
- #'+ 2 * xval * betas_cov |
||
| 232 | +106 |
- #' @export+ ) |
||
| 233 | -+ | |||
| 107 | +7x |
- has_counts_difference <- function(atleast, ...) {
+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
||
| 234 | -4x | +108 | +7x |
- checkmate::assert_count(atleast)+ data.frame( |
| 235 | -4x | +109 | +7x |
- CombinationFunction(function(table_row) {
+ effect = "Covariate:", |
| 236 | -30x | +110 | +7x |
- counts <- h_row_counts(table_row, ...)+ term = rep(covar, length(xval)), |
| 237 | -30x | +111 | +7x |
- difference <- diff(range(counts))+ term_label = paste0(" ", xval),
|
| 238 | -30x | +112 | +7x |
- difference >= atleast+ level = as.character(xval), |
| 239 | -+ | |||
| 113 | +7x |
- })+ n = NA, |
||
| 240 | -+ | |||
| 114 | +7x |
- }+ hr = exp(coef_hat), |
| 1 | -+ | |||
| 115 | +7x |
- #' Count occurrences by grade+ lcl = exp(coef_hat - q_norm * coef_se), |
||
| 2 | -+ | |||
| 116 | +7x |
- #'+ ucl = exp(coef_hat + q_norm * coef_se), |
||
| 3 | -+ | |||
| 117 | +7x |
- #' @description `r lifecycle::badge("stable")`
+ pval = NA, |
||
| 4 | -+ | |||
| 118 | +7x |
- #'+ pval_inter = NA,+ |
+ ||
| 119 | +7x | +
+ stringsAsFactors = FALSE |
||
| 5 | +120 |
- #' The analyze function [count_occurrences_by_grade()] creates a layout element to calculate occurrence counts by grade.+ ) |
||
| 6 | +121 |
- #'+ } |
||
| 7 | +122 |
- #' This function analyzes primary analysis variable `var` which indicates toxicity grades. The `id` variable+ |
||
| 8 | +123 |
- #' is used to indicate unique subject identifiers (defaults to `USUBJID`). The user can also supply a list of+ #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate. |
||
| 9 | +124 |
- #' custom groups of grades to analyze via the `grade_groups` parameter. The `remove_single` argument will+ #' |
||
| 10 | +125 |
- #' remove single grades from the analysis so that *only* grade groups are analyzed.+ #' @method h_coxreg_inter_effect factor |
||
| 11 | +126 |
#' |
||
| 12 | +127 |
- #' If there are multiple grades recorded for one patient only the highest grade level is counted.+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 13 | +128 |
#' |
||
| 14 | +129 |
- #' The summarize function [summarize_occurrences_by_grade()] performs the same function as+ #' @export |
||
| 15 | +130 |
- #' [count_occurrences_by_grade()] except it creates content rows, not data rows, to summarize the current table+ h_coxreg_inter_effect.factor <- function(x, |
||
| 16 | +131 |
- #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have+ effect, |
||
| 17 | +132 |
- #' occurred.+ covar, |
||
| 18 | +133 |
- #'+ mod, |
||
| 19 | +134 |
- #' @inheritParams count_occurrences+ label, |
||
| 20 | +135 |
- #' @inheritParams argument_convention+ control, |
||
| 21 | +136 |
- #' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades.+ data, |
||
| 22 | +137 |
- #' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups+ ...) {
|
||
| 23 | -+ | |||
| 138 | +17x |
- #' in the the output list; in this case only the grade groups names will be included in the output. If+ lvl_given <- levels(x) |
||
| 24 | -+ | |||
| 139 | +17x |
- #' `only_grade_groups` is set to `TRUE` this argument is ignored.+ y <- h_coxreg_inter_estimations( |
||
| 25 | -+ | |||
| 140 | +17x |
- #' @param only_grade_groups (`flag`)\cr whether only the specified grade groups should be+ variable = effect, given = covar, |
||
| 26 | -+ | |||
| 141 | +17x |
- #' included, with individual grade rows removed (`TRUE`), or all grades and grade groups+ lvl_var = levels(data[[effect]]), |
||
| 27 | -+ | |||
| 142 | +17x |
- #' should be displayed (`FALSE`).+ lvl_given = lvl_given, |
||
| 28 | -+ | |||
| 143 | +17x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ mod = mod, |
||
| 29 | -+ | |||
| 144 | +17x |
- #'+ conf_level = 0.95 |
||
| 30 | -+ | |||
| 145 | +17x |
- #' Options are: ``r shQuote(get_stats("count_occurrences_by_grade"))``
+ )[[1]] |
||
| 31 | +146 |
- #'+ |
||
| 32 | -+ | |||
| 147 | +17x |
- #' @seealso Relevant helper function [h_append_grade_groups()].+ data.frame( |
||
| 33 | -+ | |||
| 148 | +17x |
- #'+ effect = "Covariate:",+ |
+ ||
| 149 | +17x | +
+ term = rep(covar, nrow(y)),+ |
+ ||
| 150 | +17x | +
+ term_label = paste0(" ", lvl_given),
+ |
+ ||
| 151 | +17x | +
+ level = lvl_given,+ |
+ ||
| 152 | +17x | +
+ n = NA,+ |
+ ||
| 153 | +17x | +
+ hr = y[, "hr"],+ |
+ ||
| 154 | +17x | +
+ lcl = y[, "lcl"],+ |
+ ||
| 155 | +17x | +
+ ucl = y[, "ucl"],+ |
+ ||
| 156 | +17x | +
+ pval = NA,+ |
+ ||
| 157 | +17x | +
+ pval_inter = NA,+ |
+ ||
| 158 | +17x | +
+ stringsAsFactors = FALSE |
||
| 34 | +159 |
- #' @name count_occurrences_by_grade+ ) |
||
| 35 | +160 |
- #' @order 1+ } |
||
| 36 | +161 |
- NULL+ |
||
| 37 | +162 |
-
+ #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate. |
||
| 38 | +163 |
- #' Helper function for `s_count_occurrences_by_grade()`+ #' This makes an automatic conversion to `factor` and then forwards to the method for factors. |
||
| 39 | +164 |
#' |
||
| 40 | +165 |
- #' @description `r lifecycle::badge("stable")`
+ #' @method h_coxreg_inter_effect character |
||
| 41 | +166 |
#' |
||
| 42 | +167 |
- #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with+ #' @note |
||
| 43 | +168 |
- #' individual grade frequencies. The order of the final result follows the order of `grade_groups`.+ #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is |
||
| 44 | +169 |
- #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to+ #' therefore better to always pre-process the dataset such that factors are manually created from character |
||
| 45 | +170 |
- #' the end. Grade groups names must be unique.+ #' variables before passing the dataset to [rtables::build_table()]. |
||
| 46 | +171 |
#' |
||
| 47 | +172 |
- #' @inheritParams count_occurrences_by_grade+ #' @export |
||
| 48 | +173 |
- #' @param refs (named `list` of `numeric`)\cr named list where each name corresponds to a reference grade level+ h_coxreg_inter_effect.character <- function(x, |
||
| 49 | +174 |
- #' and each entry represents a count.+ effect, |
||
| 50 | +175 |
- #'+ covar, |
||
| 51 | +176 |
- #' @return Formatted list of grade groupings.+ mod, |
||
| 52 | +177 |
- #'+ label, |
||
| 53 | +178 |
- #' @examples+ control, |
||
| 54 | +179 |
- #' h_append_grade_groups(+ data, |
||
| 55 | +180 |
- #' list(+ ...) {
|
||
| 56 | -+ | |||
| 181 | +5x |
- #' "Any Grade" = as.character(1:5),+ y <- as.factor(x) |
||
| 57 | +182 |
- #' "Grade 1-2" = c("1", "2"),
+
|
||
| 58 | -+ | |||
| 183 | +5x |
- #' "Grade 3-4" = c("3", "4")
+ h_coxreg_inter_effect( |
||
| 59 | -+ | |||
| 184 | +5x |
- #' ),+ x = y, |
||
| 60 | -+ | |||
| 185 | +5x |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ effect = effect, |
||
| 61 | -+ | |||
| 186 | +5x |
- #' )+ covar = covar, |
||
| 62 | -+ | |||
| 187 | +5x |
- #'+ mod = mod, |
||
| 63 | -+ | |||
| 188 | +5x |
- #' h_append_grade_groups(+ label = label, |
||
| 64 | -+ | |||
| 189 | +5x |
- #' list(+ control = control,+ |
+ ||
| 190 | +5x | +
+ data = data, |
||
| 65 | +191 |
- #' "Any Grade" = as.character(5:1),+ ... |
||
| 66 | +192 |
- #' "Grade A" = "5",+ ) |
||
| 67 | +193 |
- #' "Grade B" = c("4", "3")
+ } |
||
| 68 | +194 |
- #' ),+ |
||
| 69 | +195 |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ #' @describeIn cox_regression_inter A higher level function to get |
||
| 70 | +196 |
- #' )+ #' the results of the interaction test and the estimated values. |
||
| 71 | +197 |
#' |
||
| 72 | +198 |
- #' h_append_grade_groups(+ #' @return |
||
| 73 | +199 |
- #' list(+ #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If |
||
| 74 | +200 |
- #' "Any Grade" = as.character(1:5),+ #' no interaction, [h_coxreg_univar_extract()] is applied instead. |
||
| 75 | +201 |
- #' "Grade 1-2" = c("1", "2"),
+ #' |
||
| 76 | +202 |
- #' "Grade 3-4" = c("3", "4")
+ #' @examples |
||
| 77 | +203 |
- #' ),+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
||
| 78 | +204 |
- #' list("1" = 10, "2" = 5, "3" = 0)
+ #' h_coxreg_extract_interaction( |
||
| 79 | +205 |
- #' )+ #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder, |
||
| 80 | +206 |
- #'+ #' control = control_coxreg() |
||
| 81 | +207 |
- #' @export+ #' ) |
||
| 82 | +208 |
- h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only_grade_groups = FALSE) {
+ #' |
||
| 83 | -32x | +|||
| 209 | +
- checkmate::assert_list(grade_groups)+ #' @export |
|||
| 84 | -32x | +|||
| 210 | +
- checkmate::assert_list(refs)+ h_coxreg_extract_interaction <- function(effect, |
|||
| 85 | -32x | +|||
| 211 | +
- refs_orig <- refs+ covar, |
|||
| 86 | -32x | +|||
| 212 | +
- elements <- unique(unlist(grade_groups))+ mod, |
|||
| 87 | +213 |
-
+ data, |
||
| 88 | +214 |
- ### compute sums in groups+ at, |
||
| 89 | -32x | +|||
| 215 | +
- grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))+ control) {
|
|||
| 90 | -32x | +216 | +31x |
- if (!checkmate::test_subset(elements, names(refs))) {
+ if (!any(attr(stats::terms(mod), "order") == 2)) {
|
| 91 | -2x | +217 | +12x |
- padding_el <- setdiff(elements, names(refs))+ y <- h_coxreg_univar_extract( |
| 92 | -2x | +218 | +12x |
- refs[padding_el] <- 0+ effect = effect, covar = covar, mod = mod, data = data, control = control |
| 93 | +219 |
- }+ ) |
||
| 94 | -32x | +220 | +12x |
- result <- c(grp_sum, refs)+ y$pval_inter <- NA |
| 95 | -+ | |||
| 221 | +12x |
-
+ y |
||
| 96 | +222 |
- ### order result while keeping grade_groups's ordering+ } else {
|
||
| 97 | -32x | +223 | +19x |
- ordr <- grade_groups+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
| 98 | +224 | |||
| 99 | +225 |
- # elements of any-grade group (if any) will be moved to the end- |
- ||
| 100 | -32x | -
- is_any <- sapply(grade_groups, setequal, y = names(refs))+ # Test the main treatment effect. |
||
| 101 | -32x | -
- ordr[is_any] <- list(character(0)) # hide elements under any-grade group- |
- ||
| 102 | -- | - - | -||
| 103 | -+ | 226 | +19x |
- # groups-elements combined sequence+ mod_aov <- muffled_car_anova(mod, test_statistic) |
| 104 | -32x | +227 | +19x |
- ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)+ sum_anova <- broom::tidy(mod_aov) |
| 105 | -32x | +228 | +19x |
- ordr <- ordr[!duplicated(ordr)]+ pval <- sum_anova[sum_anova$term == effect, ][["p.value"]] |
| 106 | +229 | |||
| 107 | +230 |
- # append remaining elements (if any)+ # Test the interaction effect. |
||
| 108 | -32x | +231 | +19x |
- ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group+ pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
|
| 109 | -32x | -
- ordr <- union(ordr, names(refs)) # from refs- |
- ||
| 110 | -+ | 232 | +19x |
-
+ covar_test <- data.frame( |
| 111 | -+ | |||
| 233 | +19x |
- # remove elements of single-element groups, if any+ effect = "Covariate:", |
||
| 112 | -32x | +234 | +19x |
- if (only_grade_groups) {
+ term = covar, |
| 113 | -3x | +235 | +19x |
- ordr <- intersect(ordr, names(grade_groups))+ term_label = unname(labels_or_names(data[covar])), |
| 114 | -29x | +236 | +19x |
- } else if (remove_single) {
+ level = "", |
| 115 | -29x | +237 | +19x |
- is_single <- sapply(grade_groups, length) == 1L+ n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval, |
| 116 | -29x | +238 | +19x |
- ordr <- setdiff(ordr, unlist(grade_groups[is_single]))+ pval_inter = pval_inter, |
| 117 | -+ | |||
| 239 | +19x |
- }+ stringsAsFactors = FALSE |
||
| 118 | +240 |
-
+ ) |
||
| 119 | +241 |
- # apply the order+ # Estimate the interaction. |
||
| 120 | -32x | -
- result <- result[ordr]- |
- ||
| 121 | -+ | 242 | +19x |
-
+ y <- h_coxreg_inter_effect( |
| 122 | -+ | |||
| 243 | +19x |
- # remove groups without any elements in the original refs+ data[[covar]], |
||
| 123 | -+ | |||
| 244 | +19x |
- # note: it's OK if groups have 0 value+ covar = covar, |
||
| 124 | -32x | +245 | +19x |
- keep_grp <- vapply(grade_groups, function(x, rf) {
+ effect = effect, |
| 125 | -64x | +246 | +19x |
- any(x %in% rf)+ mod = mod, |
| 126 | -32x | +247 | +19x |
- }, rf = names(refs_orig), logical(1))+ label = unname(labels_or_names(data[covar])), |
| 127 | -+ | |||
| 248 | +19x |
-
+ at = at, |
||
| 128 | -32x | +249 | +19x |
- keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp]+ control = control, |
| 129 | -32x | +250 | +19x |
- result <- result[keep_el]+ data = data |
| 130 | +251 |
-
+ ) |
||
| 131 | -32x | +252 | +19x |
- result+ rbind(covar_test, y) |
| 132 | +253 |
- }+ } |
||
| 133 | +254 |
-
+ } |
||
| 134 | +255 |
- #' @describeIn count_occurrences_by_grade Statistics function which counts the+ |
||
| 135 | +256 |
- #' number of patients by highest grade.+ #' @describeIn cox_regression_inter Hazard ratio estimation in interactions. |
||
| 136 | +257 |
#' |
||
| 137 | +258 |
- #' @return+ #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation |
||
| 138 | +259 |
- #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or+ #' of the levels of `variable` given the levels of `given`. |
||
| 139 | +260 |
- #' grade level grouping.+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels as given by [levels()]. |
||
| 140 | +261 |
- #'+ #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]). |
||
| 141 | +262 |
- #' @examples+ #' |
||
| 142 | +263 |
- #' s_count_occurrences_by_grade(+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
||
| 143 | +264 |
- #' df,+ #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex. |
||
| 144 | +265 |
- #' .N_col = 10L,+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 145 | +266 |
- #' .var = "AETOXGR",+ #' |
||
| 146 | +267 |
- #' id = "USUBJID",+ #' - b1 (arm b), b2 (arm c) |
||
| 147 | +268 |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ #' - b3 (sex m) |
||
| 148 | +269 |
- #' )+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 149 | +270 |
#' |
||
| 150 | +271 |
- #' @export+ #' The estimation of the Hazard Ratio for arm C/sex M is given in reference |
||
| 151 | +272 |
- s_count_occurrences_by_grade <- function(df,+ #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5). |
||
| 152 | +273 |
- .var,+ #' The interaction coefficient is deduced by b2 + b5 while the standard error |
||
| 153 | +274 |
- .N_row, # nolint+ #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$. |
||
| 154 | +275 |
- .N_col, # nolint+ #' |
||
| 155 | +276 |
- id = "USUBJID",+ #' @return |
||
| 156 | +277 |
- grade_groups = list(),+ #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding |
||
| 157 | +278 |
- remove_single = TRUE,+ #' to the combinations of `variable` and `given`, with columns: |
||
| 158 | +279 |
- only_grade_groups = FALSE,+ #' * `coef_hat`: Estimation of the coefficient. |
||
| 159 | +280 |
- denom = c("N_col", "n", "N_row"),
+ #' * `coef_se`: Standard error of the estimation. |
||
| 160 | +281 |
- labelstr = "") {
+ #' * `hr`: Hazard ratio. |
||
| 161 | -75x | +|||
| 282 | +
- assert_valid_factor(df[[.var]])+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
|||
| 162 | -75x | +|||
| 283 | +
- assert_df_with_variables(df, list(grade = .var, id = id))+ #' |
|||
| 163 | +284 |
-
+ #' @examples |
||
| 164 | -75x | +|||
| 285 | +
- denom <- match.arg(denom) %>%+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
|||
| 165 | -75x | +|||
| 286 | +
- switch(+ #' result <- h_coxreg_inter_estimations( |
|||
| 166 | -75x | +|||
| 287 | +
- n = nlevels(factor(df[[id]])),+ #' variable = "armcd", given = "covar1", |
|||
| 167 | -75x | +|||
| 288 | +
- N_row = .N_row,+ #' lvl_var = levels(dta_bladder$armcd), |
|||
| 168 | -75x | +|||
| 289 | +
- N_col = .N_col+ #' lvl_given = levels(dta_bladder$covar1), |
|||
| 169 | +290 |
- )+ #' mod = mod, conf_level = .95 |
||
| 170 | +291 |
-
+ #' ) |
||
| 171 | -75x | +|||
| 292 | +
- if (nrow(df) < 1) {
+ #' result |
|||
| 172 | -5x | +|||
| 293 | +
- grade_levels <- levels(df[[.var]])+ #' |
|||
| 173 | -5x | +|||
| 294 | +
- l_count <- as.list(rep(0, length(grade_levels)))+ #' @export |
|||
| 174 | -5x | +|||
| 295 | +
- names(l_count) <- grade_levels+ h_coxreg_inter_estimations <- function(variable, |
|||
| 175 | +296 |
- } else {
+ given, |
||
| 176 | -70x | +|||
| 297 | +
- if (isTRUE(is.factor(df[[id]]))) {
+ lvl_var, |
|||
| 177 | -! | +|||
| 298 | +
- assert_valid_factor(df[[id]], any.missing = FALSE)+ lvl_given, |
|||
| 178 | +299 |
- } else {
+ mod, |
||
| 179 | -70x | +|||
| 300 | +
- checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE)+ conf_level = 0.95) {
|
|||
| 180 | -+ | |||
| 301 | +18x |
- }+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
||
| 181 | -70x | +302 | +18x |
- checkmate::assert_count(.N_col)+ giv_lvl <- paste0(given, lvl_given) |
| 182 | -+ | |||
| 303 | +18x |
-
+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
||
| 183 | -70x | +304 | +18x |
- id <- df[[id]]+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 184 | -70x | +305 | +18x |
- grade <- df[[.var]]+ design_mat <- within( |
| 185 | -+ | |||
| 306 | +18x |
-
+ data = design_mat, |
||
| 186 | -70x | +307 | +18x |
- if (!is.ordered(grade)) {
+ expr = {
|
| 187 | -70x | +308 | +18x |
- grade_lbl <- obj_label(grade)+ inter <- paste0(variable, ":", given) |
| 188 | -70x | +309 | +18x |
- lvls <- levels(grade)+ rev_inter <- paste0(given, ":", variable)+ |
+
| 310 | ++ |
+ }+ |
+ ||
| 311 | ++ |
+ ) |
||
| 189 | -70x | +312 | +18x |
- if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
+ split_by_variable <- design_mat$variable |
| 190 | -69x | +313 | +18x |
- lvl_ord <- lvls+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
| 191 | +314 |
- } else {
+
|
||
| 192 | -1x | +315 | +18x |
- lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
+ mmat <- stats::model.matrix(mod)[1, ] |
| 193 | -1x | +316 | +18x |
- lvl_ord <- levels(grade)[order(as.numeric(lvls))]+ mmat[!mmat == 0] <- 0 |
| 194 | +317 |
- }+ |
||
| 195 | -70x | +318 | +18x |
- grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)+ design_mat <- apply(+ |
+
| 319 | +18x | +
+ X = design_mat, MARGIN = 1, FUN = function(x) {
+ |
+ ||
| 320 | +52x | +
+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ |
+ ||
| 321 | +52x | +
+ mmat |
||
| 196 | +322 |
} |
||
| 197 | +323 |
-
+ ) |
||
| 198 | -70x | +324 | +18x |
- missing_lvl <- grepl("missing", tolower(levels(grade)))
+ colnames(design_mat) <- interaction_names+ |
+
| 325 | ++ | + | ||
| 199 | -70x | +326 | +18x |
- if (any(missing_lvl)) {
+ coef <- stats::coef(mod) |
| 200 | -1x | +327 | +18x |
- grade <- factor(+ vcov <- stats::vcov(mod) |
| 201 | -1x | +328 | +18x |
- grade,+ betas <- as.matrix(coef) |
| 202 | -1x | +329 | +18x |
- levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]),+ coef_hat <- t(design_mat) %*% betas |
| 203 | -1x | +330 | +18x |
- ordered = is.ordered(grade)+ dimnames(coef_hat)[2] <- "coef" |
| 204 | -+ | |||
| 331 | +18x |
- )+ coef_se <- apply( |
||
| 205 | -+ | |||
| 332 | +18x |
- }+ design_mat, 2, |
||
| 206 | -70x | +333 | +18x |
- df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE)+ function(x) {
|
| 207 | -70x | +334 | +52x |
- l_count <- as.list(table(df_max$grade))+ vcov_el <- as.logical(x) |
| 208 | -+ | |||
| 335 | +52x |
- }+ y <- vcov[vcov_el, vcov_el] |
||
| 209 | -+ | |||
| 336 | +52x |
-
+ y <- sum(y) |
||
| 210 | -75x | +337 | +52x |
- if (length(grade_groups) > 0) {
+ y <- sqrt(y) |
| 211 | -30x | +338 | +52x |
- l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups)+ return(y) |
| 212 | +339 |
- }+ } |
||
| 213 | +340 |
-
+ ) |
||
| 214 | -75x | +341 | +18x |
- l_count_fraction <- lapply(+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 215 | -75x | +342 | +18x |
- l_count,+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
| 216 | -75x | +343 | +18x |
- function(i, denom) {
+ y <- apply(y, 1, function(x) {
|
| 217 | -299x | +344 | +52x |
- if (i == 0 && denom == 0) {
+ x["hr"] <- exp(x["coef"]) |
| 218 | -9x | +345 | +52x |
- c(0, 0)+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
| 219 | -+ | |||
| 346 | +52x |
- } else {
+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
||
| 220 | -290x | +347 | +52x |
- c(i, i / denom)+ x |
| 221 | +348 |
- }+ }) |
||
| 222 | -+ | |||
| 349 | +18x |
- },+ y <- t(y) |
||
| 223 | -75x | +350 | +18x |
- denom = denom+ y <- by(y, split_by_variable, identity) |
| 224 | -+ | |||
| 351 | +18x |
- )+ y <- lapply(y, as.matrix) |
||
| 225 | -+ | |||
| 352 | +18x |
-
+ attr(y, "details") <- paste0( |
||
| 226 | -75x | +353 | +18x |
- list(+ "Estimations of ", variable, |
| 227 | -75x | +354 | +18x |
- count_fraction = l_count_fraction+ " hazard ratio given the level of ", given, " compared to ",+ |
+
| 355 | +18x | +
+ variable, " level ", lvl_var[1], "." |
||
| 228 | +356 |
) |
||
| 229 | -+ | |||
| 357 | +18x |
- }+ y |
||
| 230 | +358 |
-
+ } |
| 231 | +1 |
- #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun`+ #' Line plot with optional table |
||
| 232 | +2 |
- #' in `count_occurrences_by_grade()`.+ #' |
||
| 233 | +3 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 234 | +4 |
- #' @return+ #' |
||
| 235 | +5 |
- #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ #' Line plot with optional table. |
||
| 236 | +6 |
#' |
||
| 237 | +7 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 238 | +8 |
- #' a_count_occurrences_by_grade(+ #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) |
||
| 239 | +9 |
- #' df,+ #' to counts objects in groups for stratification. |
||
| 240 | +10 |
- #' .N_col = 10L,+ #' @param variables (named `character`) vector of variable names in `df` which should include: |
||
| 241 | +11 |
- #' .N_row = 10L,+ #' * `x` (`string`)\cr name of x-axis variable. |
||
| 242 | +12 |
- #' .var = "AETOXGR",+ #' * `y` (`string`)\cr name of y-axis variable. |
||
| 243 | +13 |
- #' id = "USUBJID",+ #' * `group_var` (`string` or `NULL`)\cr name of grouping variable (or strata), i.e. treatment arm. |
||
| 244 | +14 |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ #' Can be `NA` to indicate lack of groups. |
||
| 245 | +15 |
- #' )+ #' * `subject_var` (`string` or `NULL`)\cr name of subject variable. Only applies if `group_var` is |
||
| 246 | +16 |
- #'+ #' not NULL. |
||
| 247 | +17 |
- #' @export+ #' * `paramcd` (`string` or `NA`)\cr name of the variable for parameter's code. Used for y-axis label and plot's |
||
| 248 | +18 |
- a_count_occurrences_by_grade <- function(df,+ #' subtitle. Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle. |
||
| 249 | +19 |
- labelstr = "",+ #' * `y_unit` (`string` or `NA`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle. |
||
| 250 | +20 |
- id = "USUBJID",+ #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle. |
||
| 251 | +21 |
- grade_groups = list(),+ #' * `facet_var` (`string` or `NA`)\cr name of the secondary grouping variable used for plot faceting, i.e. treatment |
||
| 252 | +22 |
- remove_single = TRUE,+ #' arm. Can be `NA` to indicate lack of groups. |
||
| 253 | +23 |
- only_grade_groups = FALSE,+ #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints. |
||
| 254 | +24 |
- denom = c("N_col", "n", "N_row"),
+ #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`, |
||
| 255 | +25 |
- .N_col, # nolint+ #' and be of a `double` or `numeric` type vector of length one. |
||
| 256 | +26 |
- .N_row, # nolint+ #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals. |
||
| 257 | +27 |
- .df_row,+ #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`, |
||
| 258 | +28 |
- .var = NULL,+ #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be |
||
| 259 | +29 |
- .stats = NULL,+ #' added to the plot. |
||
| 260 | +30 |
- .formats = NULL,+ #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names |
||
| 261 | +31 |
- .labels = NULL,+ #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of |
||
| 262 | +32 |
- .indent_mods = NULL,+ #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting |
||
| 263 | +33 |
- na_str = default_na_str()) {
+ #' `interval = NULL`. |
||
| 264 | -56x | +|||
| 34 | +
- x_stats <- s_count_occurrences_by_grade(+ #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot. |
|||
| 265 | -56x | +|||
| 35 | +
- df = df, .var = .var, .N_row = .N_row, .N_col = .N_col, id = id,+ #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`. |
|||
| 266 | -56x | +|||
| 36 | +
- grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups,+ #' @param sfun (`function`)\cr the function to compute the values of required statistics. It must return a named `list` |
|||
| 267 | -56x | +|||
| 37 | +
- denom = denom, labelstr = labelstr+ #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`, |
|||
| 268 | +38 |
- )+ #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed. |
||
| 269 | +39 |
-
+ #' @param ... optional arguments to `sfun`. |
||
| 270 | -56x | +|||
| 40 | +
- if (is.null(unlist(x_stats))) {
+ #' @param mid_type (`string`)\cr controls the type of the `mid` plot, it can be point (`"p"`), line (`"l"`), |
|||
| 271 | -! | +|||
| 41 | +
- return(NULL)+ #' or point and line (`"pl"`). |
|||
| 272 | +42 |
- }+ #' @param mid_point_size (`numeric(1)`)\cr font size of the `mid` plot points. |
||
| 273 | -56x | +|||
| 43 | +
- x_lvls <- names(x_stats[[1]])+ #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of |
|||
| 274 | +44 |
-
+ #' a call to a position adjustment function. |
||
| 275 | +45 |
- # Fill in with formatting defaults if needed+ #' @param legend_title (`string`)\cr legend title. |
||
| 276 | -56x | +|||
| 46 | +
- .stats <- get_stats("count_occurrences_by_grade", stats_in = .stats)
+ #' @param legend_position (`string`)\cr the position of the plot legend (`"none"`, `"left"`, `"right"`, `"bottom"`, |
|||
| 277 | -56x | +|||
| 47 | +
- if (length(.formats) == 1 && is.null(names(.formats))) {
+ #' `"top"`, or a two-element numeric vector). |
|||
| 278 | -4x | +|||
| 48 | +
- .formats <- rep(.formats, length(.stats)) %>% setNames(.stats)+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
|||
| 279 | +49 |
- }+ #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing |
||
| 280 | -56x | +|||
| 50 | +
- .formats <- get_formats_from_stats(.stats, .formats)+ #' between ticks on the x-axis, for use when `variables$x` is numeric. If `NULL` (default), [labeling::extended()] is |
|||
| 281 | -56x | +|||
| 51 | +
- .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls)+ #' used to determine optimal tick positions on the x-axis. If `variables$x` is not numeric, this argument is ignored. |
|||
| 282 | -56x | +|||
| 52 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls)+ #' @param x_lab (`string` or `NULL`)\cr x-axis label. If `NULL` then no label will be added. |
|||
| 283 | +53 |
-
+ #' @param y_lab (`string` or `NULL`)\cr y-axis label. If `NULL` then no label will be added. |
||
| 284 | -1x | +|||
| 54 | +
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ #' @param y_lab_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be added |
|||
| 285 | -56x | +|||
| 55 | +
- x_stats <- x_stats[.stats]+ #' to the y-axis label (`y_lab`). |
|||
| 286 | +56 |
-
+ #' @param y_lab_add_unit (`flag`)\cr whether y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be added |
||
| 287 | +57 |
- # Ungroup statistics with values for each level of x+ #' to the y-axis label (`y_lab`). |
||
| 288 | -56x | +|||
| 58 | +
- x_ungrp <- ungroup_stats(x_stats, .formats, .labels, list())+ #' @param title (`string`)\cr plot title. |
|||
| 289 | -56x | +|||
| 59 | +
- x_stats <- x_ungrp[["x"]]+ #' @param subtitle (`string`)\cr plot subtitle. |
|||
| 290 | -56x | +|||
| 60 | +
- .formats <- x_ungrp[[".formats"]]+ #' @param subtitle_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be |
|||
| 291 | +61 |
-
+ #' added to the plot's subtitle (`subtitle`). |
||
| 292 | +62 |
- # Auto format handling+ #' @param subtitle_add_unit (`flag`)\cr whether the y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be |
||
| 293 | -56x | +|||
| 63 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' added to the plot's subtitle (`subtitle`). |
|||
| 294 | +64 |
-
+ #' @param caption (`string`)\cr optional caption below the plot. |
||
| 295 | -56x | +|||
| 65 | +
- in_rows(+ #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the |
|||
| 296 | -56x | +|||
| 66 | +
- .list = x_stats,+ #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format` |
|||
| 297 | -56x | +|||
| 67 | +
- .formats = .formats,+ #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function. |
|||
| 298 | -56x | +|||
| 68 | +
- .names = unlist(.labels),+ #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table |
|||
| 299 | -56x | +|||
| 69 | +
- .labels = unlist(.labels),+ #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function. |
|||
| 300 | -56x | +|||
| 70 | +
- .indent_mods = .indent_mods,+ #' @param table_font_size (`numeric(1)`)\cr font size of the text in the table. |
|||
| 301 | -56x | +|||
| 71 | +
- .format_na_strs = na_str+ #' @param newpage `r lifecycle::badge("deprecated")` not used.
|
|||
| 302 | +72 |
- )+ #' @param col (`character`)\cr color(s). See `?ggplot2::aes_colour_fill_alpha` for example values. |
||
| 303 | +73 |
- }+ #' @param linetype (`character`)\cr line type(s). See `?ggplot2::aes_linetype_size_shape` for example values. |
||
| 304 | +74 |
-
+ #' @param errorbar_width (`numeric(1)`)\cr width of the error bars. |
||
| 305 | +75 |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function+ #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the line plot. |
||
| 306 | +76 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' Relative height of annotation table is then `1 - rel_height_plot`. If `table = NULL`, this parameter is ignored. |
||
| 307 | +77 |
- #'+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `table` is not `NULL`. |
||
| 308 | +78 |
- #' @return+ #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the |
||
| 309 | +79 |
- #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ #' annotation table is printed below the plot via [cowplot::plot_grid()]. |
||
| 310 | +80 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 311 | +81 |
- #' the statistics from `s_count_occurrences_by_grade()` to the table layout.+ #' @return A `ggplot` line plot (and statistics table if applicable). |
||
| 312 | +82 |
#' |
||
| 313 | +83 |
#' @examples |
||
| 314 | +84 |
- #' library(dplyr)+ #' |
||
| 315 | +85 |
- #'+ #' adsl <- tern_ex_adsl |
||
| 316 | +86 |
- #' df <- data.frame(+ #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING") |
||
| 317 | +87 |
- #' USUBJID = as.character(c(1:6, 1)),+ #' adlb$AVISIT <- droplevels(adlb$AVISIT) |
||
| 318 | +88 |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
+ #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) |
||
| 319 | +89 |
- #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)),+ #' |
||
| 320 | +90 |
- #' AESEV = factor(+ #' # Mean with CI |
||
| 321 | +91 |
- #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
+ #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:") |
||
| 322 | +92 |
- #' levels = c("MILD", "MODERATE", "SEVERE")
+ #' |
||
| 323 | +93 |
- #' ),+ #' # Mean with CI, no stratification with group_var |
||
| 324 | +94 |
- #' stringsAsFactors = FALSE+ #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA)) |
||
| 325 | +95 |
- #' )+ #' |
||
| 326 | +96 |
- #'+ #' # Mean, upper whisker of CI, no group_var(strata) counts N |
||
| 327 | +97 |
- #' df_adsl <- df %>%+ #' g_lineplot( |
||
| 328 | +98 |
- #' select(USUBJID, ARM) %>%+ #' adlb, |
||
| 329 | +99 |
- #' unique()+ #' whiskers = "mean_ci_upr", |
||
| 330 | +100 |
- #'+ #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit" |
||
| 331 | +101 |
- #' # Layout creating function with custom format.+ #' ) |
||
| 332 | +102 |
- #' basic_table() %>%+ #' |
||
| 333 | +103 |
- #' split_cols_by("ARM") %>%
+ #' # Median with CI |
||
| 334 | +104 |
- #' add_colcounts() %>%+ #' g_lineplot( |
||
| 335 | +105 |
- #' count_occurrences_by_grade(+ #' adlb, |
||
| 336 | +106 |
- #' var = "AESEV",+ #' adsl, |
||
| 337 | +107 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ #' mid = "median", |
||
| 338 | +108 |
- #' ) %>%+ #' interval = "median_ci", |
||
| 339 | +109 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' whiskers = c("median_ci_lwr", "median_ci_upr"),
|
||
| 340 | +110 | ++ |
+ #' title = "Plot of Median and 95% Confidence Limits by Visit"+ |
+ |
| 111 | ++ |
+ #' )+ |
+ ||
| 112 |
#' |
|||
| 341 | +113 |
- #' # Define additional grade groupings.+ #' # Mean, +/- SD |
||
| 342 | +114 |
- #' grade_groups <- list(+ #' g_lineplot(adlb, adsl, |
||
| 343 | +115 |
- #' "-Any-" = c("1", "2", "3", "4", "5"),
+ #' interval = "mean_sdi", |
||
| 344 | +116 |
- #' "Grade 1-2" = c("1", "2"),
+ #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
|
||
| 345 | +117 |
- #' "Grade 3-5" = c("3", "4", "5")
+ #' title = "Plot of Median +/- SD by Visit" |
||
| 346 | +118 |
#' ) |
||
| 347 | +119 |
#' |
||
| 348 | +120 |
- #' basic_table() %>%+ #' # Mean with CI plot with stats table |
||
| 349 | +121 |
- #' split_cols_by("ARM") %>%
+ #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
|
||
| 350 | +122 |
- #' add_colcounts() %>%+ #' |
||
| 351 | +123 |
- #' count_occurrences_by_grade(+ #' # Mean with CI, table and customized confidence level |
||
| 352 | +124 |
- #' var = "AETOXGR",+ #' g_lineplot( |
||
| 353 | +125 |
- #' grade_groups = grade_groups,+ #' adlb, |
||
| 354 | +126 |
- #' only_grade_groups = TRUE+ #' adsl, |
||
| 355 | +127 |
- #' ) %>%+ #' table = c("n", "mean", "mean_ci"),
|
||
| 356 | +128 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' control = control_analyze_vars(conf_level = 0.80), |
||
| 357 | +129 | ++ |
+ #' title = "Plot of Mean and 80% Confidence Limits by Visit"+ |
+ |
| 130 | ++ |
+ #' )+ |
+ ||
| 131 |
#' |
|||
| 358 | +132 |
- #' @export+ #' # Mean with CI, table, filtered data |
||
| 359 | +133 |
- #' @order 2+ #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE") |
||
| 360 | +134 |
- count_occurrences_by_grade <- function(lyt,+ #' g_lineplot(adlb_f, table = c("n", "mean"))
|
||
| 361 | +135 |
- var,+ #' |
||
| 362 | +136 |
- id = "USUBJID",+ #' @export |
||
| 363 | +137 |
- grade_groups = list(),+ g_lineplot <- function(df, |
||
| 364 | +138 |
- remove_single = TRUE,+ alt_counts_df = NULL, |
||
| 365 | +139 |
- only_grade_groups = FALSE,+ variables = control_lineplot_vars(), |
||
| 366 | +140 |
- var_labels = var,+ mid = "mean", |
||
| 367 | +141 |
- show_labels = "default",+ interval = "mean_ci", |
||
| 368 | +142 |
- riskdiff = FALSE,+ whiskers = c("mean_ci_lwr", "mean_ci_upr"),
|
||
| 369 | +143 |
- na_str = default_na_str(),+ table = NULL, |
||
| 370 | +144 |
- nested = TRUE,+ sfun = s_summary, |
||
| 371 | +145 |
- ...,+ ..., |
||
| 372 | +146 |
- table_names = var,+ mid_type = "pl", |
||
| 373 | +147 |
- .stats = "count_fraction",+ mid_point_size = 2, |
||
| 374 | +148 |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ position = ggplot2::position_dodge(width = 0.4), |
||
| 375 | +149 |
- .indent_mods = NULL,+ legend_title = NULL, |
||
| 376 | +150 |
- .labels = NULL) {
+ legend_position = "bottom", |
||
| 377 | -12x | +|||
| 151 | +
- checkmate::assert_flag(riskdiff)+ ggtheme = nestcolor::theme_nest(), |
|||
| 378 | -12x | +|||
| 152 | +
- extra_args <- list(+ xticks = NULL, |
|||
| 379 | -12x | +|||
| 153 | +
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ xlim = NULL, |
|||
| 380 | +154 |
- )+ ylim = NULL, |
||
| 381 | -12x | +|||
| 155 | +
- s_args <- list(+ x_lab = obj_label(df[[variables[["x"]]]]), |
|||
| 382 | -12x | +|||
| 156 | +
- id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...+ y_lab = NULL, |
|||
| 383 | +157 |
- )+ y_lab_add_paramcd = TRUE, |
||
| 384 | +158 |
-
+ y_lab_add_unit = TRUE, |
||
| 385 | -12x | +|||
| 159 | +
- if (isFALSE(riskdiff)) {
+ title = "Plot of Mean and 95% Confidence Limits by Visit", |
|||
| 386 | -10x | +|||
| 160 | +
- extra_args <- c(extra_args, s_args)+ subtitle = "", |
|||
| 387 | +161 |
- } else {
+ subtitle_add_paramcd = TRUE, |
||
| 388 | -2x | +|||
| 162 | +
- extra_args <- c(+ subtitle_add_unit = TRUE, |
|||
| 389 | -2x | +|||
| 163 | +
- extra_args,+ caption = NULL, |
|||
| 390 | -2x | +|||
| 164 | +
- list(+ table_format = NULL, |
|||
| 391 | -2x | +|||
| 165 | +
- afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
+ table_labels = NULL, |
|||
| 392 | -2x | +|||
| 166 | +
- s_args = s_args+ table_font_size = 3, |
|||
| 393 | +167 |
- )+ errorbar_width = 0.45, |
||
| 394 | +168 |
- )+ newpage = lifecycle::deprecated(), |
||
| 395 | +169 |
- }+ col = NULL, |
||
| 396 | +170 |
-
+ linetype = NULL,+ |
+ ||
| 171 | ++ |
+ rel_height_plot = 0.5,+ |
+ ||
| 172 | ++ |
+ as_list = FALSE) {
|
||
| 397 | -12x | +173 | +13x |
- analyze(+ checkmate::assert_character(variables, any.missing = TRUE) |
| 398 | -12x | +174 | +13x |
- lyt = lyt,+ checkmate::assert_character(mid, null.ok = TRUE) |
| 399 | -12x | +175 | +13x |
- vars = var,+ checkmate::assert_character(interval, null.ok = TRUE) |
| 400 | -12x | +176 | +13x |
- afun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff),+ checkmate::assert_character(col, null.ok = TRUE) |
| 401 | -12x | +177 | +13x |
- var_labels = var_labels,+ checkmate::assert_character(linetype, null.ok = TRUE) |
| 402 | -12x | +178 | +13x |
- show_labels = show_labels,+ checkmate::assert_numeric(xticks, null.ok = TRUE) |
| 403 | -12x | +179 | +13x |
- table_names = table_names,+ checkmate::assert_numeric(xlim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
| 404 | -12x | +180 | +13x |
- na_str = na_str,+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
| 405 | -12x | +181 | +13x |
- nested = nested,+ checkmate::assert_number(errorbar_width, lower = 0) |
| 406 | -12x | +182 | +13x |
- extra_args = extra_args+ checkmate::assert_string(title, null.ok = TRUE) |
| 407 | -+ | |||
| 183 | +13x |
- )+ checkmate::assert_string(subtitle, null.ok = TRUE) |
||
| 408 | -+ | |||
| 184 | +13x |
- }+ assert_proportion_value(rel_height_plot) |
||
| 409 | -+ | |||
| 185 | +13x |
-
+ checkmate::assert_logical(as_list) |
||
| 410 | +186 |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments+ |
||
| 411 | -+ | |||
| 187 | +13x |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ if (!is.null(table)) {
|
||
| 412 | -+ | |||
| 188 | +5x |
- #'+ table_format <- get_formats_from_stats(table) |
||
| 413 | -+ | |||
| 189 | +5x |
- #' @return+ table_labels <- get_labels_from_stats(table) |
||
| 414 | +190 |
- #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ } |
||
| 415 | +191 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ |
||
| 416 | -+ | |||
| 192 | +13x |
- #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout.+ extra_args <- list(...) |
||
| 417 | -+ | |||
| 193 | +13x |
- #'+ if ("control" %in% names(extra_args)) {
|
||
| 418 | -+ | |||
| 194 | +4x |
- #' @examples+ if (!is.null(table) && all(table_labels == get_labels_from_stats(table))) {
|
||
| 419 | -+ | |||
| 195 | +3x |
- #' # Layout creating function with custom format.+ table_labels <- table_labels %>% labels_use_control(extra_args[["control"]]) |
||
| 420 | +196 |
- #' basic_table() %>%+ } |
||
| 421 | +197 |
- #' add_colcounts() %>%+ } |
||
| 422 | +198 |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+
|
||
| 423 | -+ | |||
| 199 | +13x |
- #' summarize_occurrences_by_grade(+ if (is.character(interval)) {
|
||
| 424 | -+ | |||
| 200 | +13x |
- #' var = "AESEV",+ checkmate::assert_vector(whiskers, min.len = 0, max.len = 2) |
||
| 425 | +201 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ } |
||
| 426 | +202 |
- #' ) %>%+ |
||
| 427 | -+ | |||
| 203 | +13x |
- #' build_table(df, alt_counts_df = df_adsl)+ if (length(whiskers) == 1) {
|
||
| 428 | -+ | |||
| 204 | +! |
- #'+ checkmate::assert_character(mid) |
||
| 429 | +205 |
- #' basic_table() %>%+ } |
||
| 430 | +206 |
- #' add_colcounts() %>%+ |
||
| 431 | -+ | |||
| 207 | +13x |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ if (is.character(mid)) {
|
||
| 432 | -+ | |||
| 208 | +13x |
- #' summarize_occurrences_by_grade(+ checkmate::assert_scalar(mid_type) |
||
| 433 | -+ | |||
| 209 | +13x |
- #' var = "AETOXGR",+ checkmate::assert_subset(mid_type, c("pl", "p", "l"))
|
||
| 434 | +210 |
- #' grade_groups = grade_groups+ } |
||
| 435 | +211 |
- #' ) %>%+ |
||
| 436 | -+ | |||
| 212 | +13x |
- #' build_table(df, alt_counts_df = df_adsl)+ x <- variables[["x"]] |
||
| 437 | -+ | |||
| 213 | +13x |
- #'+ y <- variables[["y"]] |
||
| 438 | -+ | |||
| 214 | +13x |
- #' @export+ paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables |
||
| 439 | -+ | |||
| 215 | +13x |
- #' @order 3+ y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables |
||
| 440 | -+ | |||
| 216 | +13x |
- summarize_occurrences_by_grade <- function(lyt,+ if (is.na(variables["group_var"])) {
|
||
| 441 | -+ | |||
| 217 | +1x |
- var,+ group_var <- NULL # NULL if group_var == NA or it is not in variables |
||
| 442 | +218 |
- id = "USUBJID",+ } else {
|
||
| 443 | -+ | |||
| 219 | +12x |
- grade_groups = list(),+ group_var <- variables[["group_var"]] |
||
| 444 | -+ | |||
| 220 | +12x |
- remove_single = TRUE,+ subject_var <- variables[["subject_var"]] |
||
| 445 | +221 |
- only_grade_groups = FALSE,+ } |
||
| 446 | -+ | |||
| 222 | +13x |
- riskdiff = FALSE,+ if (is.na(variables["facet_var"])) {
|
||
| 447 | -+ | |||
| 223 | +12x |
- na_str = default_na_str(),+ facet_var <- NULL # NULL if facet_var == NA or it is not in variables |
||
| 448 | +224 |
- ...,+ } else {
|
||
| 449 | -+ | |||
| 225 | +1x |
- .stats = "count_fraction",+ facet_var <- variables[["facet_var"]] |
||
| 450 | +226 |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ } |
||
| 451 | -+ | |||
| 227 | +13x |
- .indent_mods = NULL,+ checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE) |
||
| 452 | -+ | |||
| 228 | +13x |
- .labels = NULL) {
+ checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE) |
||
| 453 | -6x | +229 | +13x |
- checkmate::assert_flag(riskdiff)+ if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
|
| 454 | -6x | +230 | +13x |
- extra_args <- list(+ checkmate::assert_false(is.na(paramcd)) |
| 455 | -6x | +231 | +13x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ checkmate::assert_scalar(unique(df[[paramcd]])) |
| 456 | +232 |
- )+ } |
||
| 457 | -6x | +|||
| 233 | +
- s_args <- list(+ |
|||
| 458 | -6x | +234 | +13x |
- id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...+ checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE) |
| 459 | -+ | |||
| 235 | +13x |
- )+ checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE) |
||
| 460 | -+ | |||
| 236 | +13x |
-
+ if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
|
||
| 461 | -6x | +237 | +13x |
- if (isFALSE(riskdiff)) {
+ checkmate::assert_false(is.na(y_unit)) |
| 462 | -4x | +238 | +13x |
- extra_args <- c(extra_args, s_args)+ checkmate::assert_scalar(unique(df[[y_unit]])) |
| 463 | +239 |
- } else {
+ } |
||
| 464 | -2x | +|||
| 240 | +
- extra_args <- c(+ |
|||
| 465 | -2x | +241 | +13x |
- extra_args,+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
|
| 466 | -2x | +242 | +8x |
- list(+ checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]])) |
| 467 | -2x | +|||
| 243 | +
- afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
+ } |
|||
| 468 | -2x | +|||
| 244 | +
- s_args = s_args+ |
|||
| 469 | +245 |
- )+ ####################################### | |
||
| 470 | +246 |
- )+ # ---- Compute required statistics ---- |
||
| 471 | +247 |
- }+ ####################################### | |
||
| 472 | +248 |
-
+ # Remove unused levels for x-axis |
||
| 473 | -6x | +249 | +13x |
- summarize_row_groups(+ if (is.factor(df[[x]])) {
|
| 474 | -6x | +250 | +12x |
- lyt = lyt,+ df[[x]] <- droplevels(df[[x]]) |
| 475 | -6x | +|||
| 251 | +
- var = var,+ } |
|||
| 476 | -6x | +|||
| 252 | +
- cfun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff),+ |
|||
| 477 | -6x | +253 | +13x |
- na_str = na_str,+ if (!is.null(facet_var) && !is.null(group_var)) {
|
| 478 | -6x | +254 | +1x |
- extra_args = extra_args+ df_grp <- tidyr::expand(df, .data[[facet_var]], .data[[group_var]], .data[[x]]) # expand based on levels of factors |
| 479 | -+ | |||
| 255 | +12x |
- )+ } else if (!is.null(group_var)) {
|
||
| 480 | -+ | |||
| 256 | +11x |
- }+ df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors |
| 1 | +257 |
- #' Summarize analysis of covariance (ANCOVA) results+ } else {
|
||
| 2 | -+ | |||
| 258 | +1x |
- #'+ df_grp <- tidyr::expand(df, NULL, .data[[x]]) |
||
| 3 | +259 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +260 |
- #'+ |
||
| 5 | -+ | |||
| 261 | +13x |
- #' The analyze function [summarize_ancova()] creates a layout element to summarize ANCOVA results.+ df_grp <- df_grp %>% |
||
| 6 | -+ | |||
| 262 | +13x |
- #'+ dplyr::full_join(y = df[, c(facet_var, group_var, x, y)], by = c(facet_var, group_var, x), multiple = "all") %>% |
||
| 7 | -+ | |||
| 263 | +13x |
- #' This function can be used to analyze multiple endpoints and/or multiple timepoints within the response variable(s)+ dplyr::group_by_at(c(facet_var, group_var, x)) |
||
| 8 | +264 |
- #' specified as `vars`.+ |
||
| 9 | -+ | |||
| 265 | +13x |
- #'+ df_stats <- df_grp %>% |
||
| 10 | -+ | |||
| 266 | +13x |
- #' Additional variables for the analysis, namely an arm (grouping) variable and covariate variables, can be defined+ dplyr::summarise( |
||
| 11 | -+ | |||
| 267 | +13x |
- #' via the `variables` argument. See below for more details on how to specify `variables`. An interaction term can+ data.frame(t(do.call(c, unname(sfun(.data[[y]])[c(mid, interval)])))), |
||
| 12 | -+ | |||
| 268 | +13x |
- #' be implemented in the model if needed. The interaction variable that should interact with the arm variable is+ .groups = "drop" |
||
| 13 | +269 |
- #' specified via the `interaction_term` parameter, and the specific value of `interaction_term` for which to extract+ ) |
||
| 14 | +270 |
- #' the ANCOVA results via the `interaction_y` parameter.+ |
||
| 15 | -+ | |||
| 271 | +13x |
- #'+ df_stats <- df_stats[!is.na(df_stats[[mid]]), ] |
||
| 16 | +272 |
- #' @inheritParams h_ancova+ |
||
| 17 | +273 |
- #' @inheritParams argument_convention+ # add number of objects N in group_var (strata) |
||
| 18 | -+ | |||
| 274 | +13x |
- #' @param interaction_y (`string` or `flag`)\cr a selected item inside of the `interaction_item` variable which will be+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
|
||
| 19 | -+ | |||
| 275 | +8x |
- #' used to select the specific ANCOVA results. if the interaction is not needed, the default option is `FALSE`.+ strata_N <- paste0(group_var, "_N") # nolint |
||
| 20 | +276 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ |
||
| 21 | -+ | |||
| 277 | +8x |
- #'+ 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 |
||
| 22 | -+ | |||
| 278 | +8x |
- #' Options are: ``r shQuote(get_stats("summarize_ancova"))``
+ colnames(df_N) <- c(group_var, "N") # nolint |
||
| 23 | -+ | |||
| 279 | +8x |
- #'+ df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint |
||
| 24 | +280 |
- #' @name summarize_ancova+ |
||
| 25 | +281 |
- #' @order 1+ # keep strata factor levels |
||
| 26 | -- |
- NULL- |
- ||
| 27 | -+ | |||
| 282 | +8x |
-
+ matches <- sapply(unique(df_N[[group_var]]), function(x) {
|
||
| 28 | -+ | |||
| 283 | +22x |
- #' Helper function to return results of a linear model+ regex_pattern <- gsub("([][(){}^$.|*+?\\\\])", "\\\\\\1", x)
|
||
| 29 | -+ | |||
| 284 | +22x |
- #'+ unique(df_N[[paste0(group_var, "_N")]])[grepl( |
||
| 30 | -+ | |||
| 285 | +22x |
- #' @description `r lifecycle::badge("stable")`
+ paste0("^", regex_pattern),
|
||
| 31 | -+ | |||
| 286 | +22x |
- #'+ unique(df_N[[paste0(group_var, "_N")]]) |
||
| 32 | +287 |
- #' @inheritParams argument_convention+ )] |
||
| 33 | +288 |
- #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`.+ }) |
||
| 34 | -+ | |||
| 289 | +8x |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with expected elements:+ df_N[[paste0(group_var, "_N")]] <- factor(df_N[[group_var]]) # nolint |
||
| 35 | -+ | |||
| 290 | +8x |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ levels(df_N[[paste0(group_var, "_N")]]) <- unlist(matches) # nolint |
||
| 36 | +291 |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ |
||
| 37 | +292 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or+ # strata_N should not be in colnames(df_stats) |
||
| 38 | -+ | |||
| 293 | +8x |
- #' interaction terms indicated by `"X1 * X2"`.+ checkmate::assert_disjunct(strata_N, colnames(df_stats)) |
||
| 39 | +294 |
- #' @param interaction_item (`string` or `NULL`)\cr name of the variable that should have interactions+ |
||
| 40 | -+ | |||
| 295 | +8x |
- #' with arm. if the interaction is not needed, the default option is `NULL`.+ df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var) |
||
| 41 | -+ | |||
| 296 | +5x |
- #'+ } else if (!is.null(group_var)) {
|
||
| 42 | -+ | |||
| 297 | +4x |
- #' @return The summary of a linear model.+ strata_N <- group_var # nolint |
||
| 43 | +298 |
- #'+ } else {
|
||
| 44 | -+ | |||
| 299 | +1x |
- #' @examples+ strata_N <- NULL # nolint |
||
| 45 | +300 |
- #' h_ancova(+ } |
||
| 46 | +301 |
- #' .var = "Sepal.Length",+ |
||
| 47 | +302 |
- #' .df_row = iris,+ ############################################### | |
||
| 48 | +303 |
- #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
+ # ---- Prepare certain plot's properties. ---- |
||
| 49 | +304 |
- #' )+ ############################################### | |
||
| 50 | +305 |
- #'+ # legend title |
||
| 51 | -+ | |||
| 306 | +13x |
- #' @export+ if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
|
||
| 52 | -+ | |||
| 307 | +12x |
- h_ancova <- function(.var,+ legend_title <- attr(df[[group_var]], "label") |
||
| 53 | +308 |
- .df_row,+ } |
||
| 54 | +309 |
- variables,+ |
||
| 55 | +310 |
- interaction_item = NULL) {
+ # y label |
||
| 56 | -27x | +311 | +13x |
- checkmate::assert_string(.var)+ if (!is.null(y_lab)) {
|
| 57 | -27x | +312 | +4x |
- checkmate::assert_list(variables)+ if (y_lab_add_paramcd) {
|
| 58 | -27x | +313 | +4x |
- checkmate::assert_subset(names(variables), c("arm", "covariates"))
+ y_lab <- paste(y_lab, unique(df[[paramcd]])) |
| 59 | -27x | +|||
| 314 | +
- assert_df_with_variables(.df_row, list(rsp = .var))+ } |
|||
| 60 | +315 | |||
| 61 | -26x | +316 | +4x |
- arm <- variables$arm+ if (y_lab_add_unit) {
|
| 62 | -26x | +317 | +4x |
- covariates <- variables$covariates+ y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
|
| 63 | -26x | +|||
| 318 | +
- if (!is.null(covariates) && length(covariates) > 0) {
+ } |
|||
| 64 | +319 |
- # Get all covariate variable names in the model.+ |
||
| 65 | -11x | +320 | +4x |
- var_list <- get_covariates(covariates)+ y_lab <- trimws(y_lab) |
| 66 | -11x | +|||
| 321 | +
- assert_df_with_variables(.df_row, var_list)+ } |
|||
| 67 | +322 |
- }+ |
||
| 68 | +323 |
-
+ # subtitle |
||
| 69 | -25x | +324 | +13x |
- covariates_part <- paste(covariates, collapse = " + ")+ if (!is.null(subtitle)) {
|
| 70 | -25x | +325 | +13x |
- if (covariates_part != "") {
+ if (subtitle_add_paramcd) {
|
| 71 | -10x | +326 | +13x |
- formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm))+ subtitle <- paste(subtitle, unique(df[[paramcd]])) |
| 72 | +327 |
- } else {
+ }+ |
+ ||
| 328 | ++ | + | ||
| 73 | -15x | +329 | +13x |
- formula <- stats::as.formula(paste0(.var, " ~ ", arm))+ if (subtitle_add_unit) {
+ |
+
| 330 | +13x | +
+ subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
|
||
| 74 | +331 |
- }+ } |
||
| 75 | +332 | |||
| 76 | -25x | +333 | +13x |
- if (is.null(interaction_item)) {
+ subtitle <- trimws(subtitle) |
| 77 | -21x | +|||
| 334 | +
- specs <- arm+ } |
|||
| 78 | +335 |
- } else {
+
|
||
| 79 | -4x | +|||
| 336 | +
- specs <- c(arm, interaction_item)+ ############################### | |
|||
| 80 | +337 |
- }+ # ---- Build plot object. ---- |
||
| 81 | +338 |
-
+ ############################### | |
||
| 82 | -25x | +339 | +13x |
- lm_fit <- stats::lm(+ p <- ggplot2::ggplot( |
| 83 | -25x | +340 | +13x |
- formula = formula,+ data = df_stats, |
| 84 | -25x | +341 | +13x |
- data = .df_row+ mapping = ggplot2::aes( |
| 85 | -+ | |||
| 342 | +13x |
- )+ x = .data[[x]], y = .data[[mid]], |
||
| 86 | -25x | +343 | +13x |
- emmeans_fit <- emmeans::emmeans(+ color = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 87 | -25x | +344 | +13x |
- lm_fit,+ shape = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 88 | -+ | |||
| 345 | +13x |
- # Specify here the group variable over which EMM are desired.+ lty = if (is.null(strata_N)) NULL else .data[[strata_N]], |
||
| 89 | -25x | +346 | +13x |
- specs = specs,+ group = if (is.null(strata_N)) NULL else .data[[strata_N]] |
| 90 | +347 |
- # Pass the data again so that the factor levels of the arm variable can be inferred.- |
- ||
| 91 | -25x | -
- data = .df_row+ ) |
||
| 92 | +348 |
) |
||
| 93 | +349 | |||
| 94 | -25x | +350 | +13x |
- emmeans_fit+ if (!is.null(group_var) && nlevels(df_stats[[strata_N]]) > 6) {
|
| 95 | -+ | |||
| 351 | +1x |
- }+ p <- p + |
||
| 96 | -+ | |||
| 352 | +1x |
-
+ scale_shape_manual(values = seq(15, 15 + nlevels(df_stats[[strata_N]]))) |
||
| 97 | +353 |
- #' @describeIn summarize_ancova Statistics function that produces a named list of results+ } |
||
| 98 | +354 |
- #' of the investigated linear model.+ |
||
| 99 | -+ | |||
| 355 | +13x |
- #'+ if (!is.null(mid)) {
|
||
| 100 | +356 |
- #' @return+ # points |
||
| 101 | -+ | |||
| 357 | +13x |
- #' * `s_ancova()` returns a named list of 5 statistics:+ if (grepl("p", mid_type, fixed = TRUE)) {
|
||
| 102 | -+ | |||
| 358 | +13x |
- #' * `n`: Count of complete sample size for the group.+ p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE) |
||
| 103 | +359 |
- #' * `lsmean`: Estimated marginal means in the group.+ } |
||
| 104 | +360 |
- #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group.+ |
||
| 105 | +361 |
- #' If working with the reference group, this will be empty.+ # lines - plotted only if there is a strata grouping (group_var) |
||
| 106 | -+ | |||
| 362 | +13x |
- #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison+ if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata_N)) { # nolint
|
||
| 107 | -+ | |||
| 363 | +12x |
- #' to the reference group.+ p <- p + ggplot2::geom_line(position = position, na.rm = TRUE) |
||
| 108 | +364 |
- #' * `pval`: p-value (not adjusted for multiple comparisons).+ } |
||
| 109 | +365 |
- #'+ } |
||
| 110 | +366 |
- #' @keywords internal+ |
||
| 111 | +367 |
- s_ancova <- function(df,+ # interval |
||
| 112 | -+ | |||
| 368 | +13x |
- .var,+ if (!is.null(interval)) {
|
||
| 113 | -+ | |||
| 369 | +13x |
- .df_row,+ p <- p + |
||
| 114 | -+ | |||
| 370 | +13x |
- variables,+ ggplot2::geom_errorbar( |
||
| 115 | -+ | |||
| 371 | +13x |
- .ref_group,+ ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]), |
||
| 116 | -+ | |||
| 372 | +13x |
- .in_ref_col,+ width = errorbar_width, |
||
| 117 | -+ | |||
| 373 | +13x |
- conf_level,+ position = position |
||
| 118 | +374 |
- interaction_y = FALSE,+ ) |
||
| 119 | +375 |
- interaction_item = NULL) {
+
|
||
| 120 | -3x | +376 | +13x |
- emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item)+ if (length(whiskers) == 1) { # lwr or upr only; mid is then required
|
| 121 | +377 | - - | -||
| 122 | -3x | -
- sum_fit <- summary(+ # workaround as geom_errorbar does not provide single-direction whiskers |
||
| 123 | -3x | +|||
| 378 | +! |
- emmeans_fit,+ p <- p + |
||
| 124 | -3x | +|||
| 379 | +! |
- level = conf_level+ ggplot2::geom_linerange( |
||
| 125 | -+ | |||
| 380 | +! |
- )+ data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings |
||
| 126 | -+ | |||
| 381 | +! |
-
+ ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]), |
||
| 127 | -3x | +|||
| 382 | +! |
- arm <- variables$arm+ position = position, |
||
| 128 | -+ | |||
| 383 | +! |
-
+ na.rm = TRUE, |
||
| 129 | -3x | +|||
| 384 | +! |
- sum_level <- as.character(unique(df[[arm]]))+ show.legend = FALSE |
||
| 130 | +385 |
-
+ ) |
||
| 131 | +386 |
- # Ensure that there is only one element in sum_level.- |
- ||
| 132 | -3x | -
- checkmate::assert_scalar(sum_level)+ } |
||
| 133 | +387 | - - | -||
| 134 | -2x | -
- sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]+ } |
||
| 135 | +388 | |||
| 136 | -+ | |||
| 389 | +13x |
- # Get the index of the ref arm+ if (is.numeric(df_stats[[x]])) {
|
||
| 137 | -2x | +390 | +1x |
- if (interaction_y != FALSE) {
+ if (length(xticks) == 1) xticks <- seq(from = min(df_stats[[x]]), to = max(df_stats[[x]]), by = xticks) |
| 138 | +391 | 1x |
- y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])+ p <- p + ggplot2::scale_x_continuous(breaks = if (!is.null(xticks)) xticks else waiver(), limits = xlim) |
|
| 139 | +392 |
- # convert characters selected in interaction_y into the numeric order+ }+ |
+ ||
| 393 | ++ | + | ||
| 140 | -1x | +394 | +13x |
- interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)+ p <- p + |
| 141 | -1x | +395 | +13x |
- sum_fit_level <- sum_fit_level[interaction_y, ]+ ggplot2::scale_y_continuous(labels = scales::comma, limits = ylim) + |
| 142 | -+ | |||
| 396 | +13x |
- # if interaction is called, reset the index+ ggplot2::labs( |
||
| 143 | -1x | +397 | +13x |
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ title = title, |
| 144 | -1x | +398 | +13x |
- ref_key <- tail(ref_key, n = 1)+ subtitle = subtitle, |
| 145 | -1x | +399 | +13x |
- ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key+ caption = caption, |
| 146 | -+ | |||
| 400 | +13x |
- } else {
+ color = legend_title, |
||
| 147 | -1x | +401 | +13x |
- y <- df[[.var]]+ lty = legend_title, |
| 148 | -+ | |||
| 402 | +13x |
- # Get the index of the ref arm when interaction is not called+ shape = legend_title, |
||
| 149 | -1x | +403 | +13x |
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ x = x_lab, |
| 150 | -1x | +404 | +13x |
- ref_key <- tail(ref_key, n = 1)+ y = y_lab |
| 151 | +405 |
- }+ ) |
||
| 152 | +406 | |||
| 153 | -2x | +407 | +13x |
- if (.in_ref_col) {
+ if (!is.null(col)) {
|
| 154 | +408 | 1x |
- list(+ p <- p + |
|
| 155 | +409 | 1x |
- n = length(y[!is.na(y)]),+ ggplot2::scale_color_manual(values = col) |
|
| 156 | -1x | +|||
| 410 | +
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ } |
|||
| 157 | -1x | +411 | +13x |
- lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"),+ if (!is.null(linetype)) {
|
| 158 | +412 | 1x |
- lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ p <- p + |
|
| 159 | +413 | 1x |
- pval = formatters::with_label(character(), "p-value")- |
- |
| 160 | -- |
- )+ ggplot2::scale_linetype_manual(values = linetype) |
||
| 161 | +414 |
- } else {
+ } |
||
| 162 | +415 |
- # Estimate the differences between the marginal means.+ |
||
| 163 | -1x | +416 | +13x |
- emmeans_contrasts <- emmeans::contrast(+ if (!is.null(facet_var)) {
|
| 164 | +417 | 1x |
- emmeans_fit,- |
- |
| 165 | -- |
- # Compare all arms versus the control arm.+ p <- p + |
||
| 166 | +418 | 1x |
- method = "trt.vs.ctrl",+ facet_grid(cols = vars(df_stats[[facet_var]])) |
|
| 167 | +419 |
- # Take the arm factor from .ref_group as the control arm.- |
- ||
| 168 | -1x | -
- ref = ref_key,- |
- ||
| 169 | -1x | -
- level = conf_level+ } |
||
| 170 | +420 |
- )+ |
||
| 171 | -1x | +421 | +13x |
- sum_contrasts <- summary(+ if (!is.null(ggtheme)) {
|
| 172 | -1x | +422 | +13x |
- emmeans_contrasts,+ p <- p + ggtheme |
| 173 | +423 |
- # Derive confidence intervals, t-tests and p-values.- |
- ||
| 174 | -1x | -
- infer = TRUE,+ } else {
|
||
| 175 | -+ | |||
| 424 | +! |
- # Do not adjust the p-values for multiplicity.+ p <- p + |
||
| 176 | -1x | +|||
| 425 | +! |
- adjust = "none"+ ggplot2::theme_bw() + |
||
| 177 | -+ | |||
| 426 | +! |
- )+ ggplot2::theme( |
||
| 178 | -+ | |||
| 427 | +! |
-
+ legend.key.width = grid::unit(1, "cm"), |
||
| 179 | -1x | +|||
| 428 | +! |
- contrast_lvls <- gsub(+ legend.position = legend_position, |
||
| 180 | -1x | +|||
| 429 | +! |
- "^\\(|\\)$", "", gsub(paste0(" - \\(*", .ref_group[[arm]][1], ".*"), "", sum_contrasts$contrast)
+ legend.direction = ifelse( |
||
| 181 | -+ | |||
| 430 | +! |
- )+ legend_position %in% c("top", "bottom"),
|
||
| 182 | -1x | +|||
| 431 | +! |
- if (!is.null(interaction_item)) {
+ "horizontal", |
||
| 183 | +432 | ! |
- sum_contrasts_level <- sum_contrasts[grepl(sum_level, contrast_lvls, fixed = TRUE), ]+ "vertical" |
|
| 184 | +433 |
- } else {
+ ) |
||
| 185 | -1x | +|||
| 434 | +
- sum_contrasts_level <- sum_contrasts[sum_level == contrast_lvls, ]+ ) |
|||
| 186 | +435 |
- }+ } |
||
| 187 | -1x | +|||
| 436 | +
- if (interaction_y != FALSE) {
+
|
|||
| 188 | -! | +|||
| 437 | +
- sum_contrasts_level <- sum_contrasts_level[interaction_y, ]+ ############################################################# | |
|||
| 189 | +438 |
- }+ # ---- Optionally, add table to the bottom of the plot. ---- |
||
| 190 | +439 |
-
+ ############################################################# | |
||
| 191 | -1x | +440 | +13x |
- list(+ if (!is.null(table)) {
|
| 192 | -1x | +441 | +5x |
- n = length(y[!is.na(y)]),+ df_stats_table <- df_grp %>% |
| 193 | -1x | +442 | +5x |
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ dplyr::summarise( |
| 194 | -1x | +443 | +5x |
- lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"),+ h_format_row( |
| 195 | -1x | +444 | +5x |
- lsmean_diff_ci = formatters::with_label(+ x = sfun(.data[[y]], ...)[table], |
| 196 | -1x | +445 | +5x |
- c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),+ format = table_format, |
| 197 | -1x | +446 | +5x |
- f_conf_level(conf_level)+ labels = table_labels |
| 198 | +447 |
- ),+ ), |
||
| 199 | -1x | +448 | +5x |
- pval = formatters::with_label(sum_contrasts_level$p.value, "p-value")+ .groups = "drop" |
| 200 | +449 |
- )+ ) |
||
| 201 | +450 |
- }+ |
||
| 202 | -+ | |||
| 451 | +5x |
- }+ stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x))) |
||
| 203 | +452 | |||
| 204 | -+ | |||
| 453 | +5x |
- #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`.+ df_stats_table <- df_stats_table %>% |
||
| 205 | -+ | |||
| 454 | +5x |
- #'+ tidyr::pivot_longer( |
||
| 206 | -+ | |||
| 455 | +5x |
- #' @return+ cols = -dplyr::all_of(c(group_var, x)), |
||
| 207 | -+ | |||
| 456 | +5x |
- #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()].+ names_to = "stat", |
||
| 208 | -+ | |||
| 457 | +5x |
- #'+ values_to = "value", |
||
| 209 | -+ | |||
| 458 | +5x |
- #' @keywords internal+ names_ptypes = list(stat = factor(levels = stats_lev)) |
||
| 210 | +459 |
- a_ancova <- make_afun(+ ) |
||
| 211 | +460 |
- s_ancova,+ |
||
| 212 | -+ | |||
| 461 | +5x |
- .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
+ tbl <- ggplot2::ggplot( |
||
| 213 | -+ | |||
| 462 | +5x |
- .formats = c(+ df_stats_table, |
||
| 214 | -+ | |||
| 463 | +5x |
- "n" = "xx",+ ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]]) |
||
| 215 | +464 |
- "lsmean" = "xx.xx",+ ) + |
||
| 216 | -+ | |||
| 465 | +5x |
- "lsmean_diff" = "xx.xx",+ ggplot2::geom_text(size = table_font_size) + |
||
| 217 | -+ | |||
| 466 | +5x |
- "lsmean_diff_ci" = "(xx.xx, xx.xx)",+ ggplot2::theme_bw() + |
||
| 218 | -+ | |||
| 467 | +5x |
- "pval" = "x.xxxx | (<0.0001)"+ ggplot2::theme(+ |
+ ||
| 468 | +5x | +
+ panel.border = ggplot2::element_blank(),+ |
+ ||
| 469 | +5x | +
+ panel.grid.major = ggplot2::element_blank(),+ |
+ ||
| 470 | +5x | +
+ panel.grid.minor = ggplot2::element_blank(),+ |
+ ||
| 471 | +5x | +
+ axis.ticks = ggplot2::element_blank(),+ |
+ ||
| 472 | +5x | +
+ axis.title = ggplot2::element_blank(),+ |
+ ||
| 473 | +5x | +
+ axis.text.x = ggplot2::element_blank(),+ |
+ ||
| 474 | +5x | +
+ axis.text.y = ggplot2::element_text(+ |
+ ||
| 475 | +5x | +
+ size = table_font_size * ggplot2::.pt,+ |
+ ||
| 476 | +5x | +
+ margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5) |
||
| 219 | +477 |
- ),+ ),+ |
+ ||
| 478 | +5x | +
+ strip.text = ggplot2::element_text(hjust = 0),+ |
+ ||
| 479 | +5x | +
+ strip.text.x = ggplot2::element_text(+ |
+ ||
| 480 | +5x | +
+ size = table_font_size * ggplot2::.pt,+ |
+ ||
| 481 | +5x | +
+ margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt") |
||
| 220 | +482 |
- .null_ref_cells = FALSE+ ),+ |
+ ||
| 483 | +5x | +
+ strip.background = ggplot2::element_rect(fill = "grey95", color = NA),+ |
+ ||
| 484 | +5x | +
+ legend.position = "none" |
||
| 221 | +485 |
- )+ ) |
||
| 222 | +486 | |||
| 223 | -+ | |||
| 487 | +5x |
- #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments+ if (!is.null(group_var)) {
|
||
| 224 | -+ | |||
| 488 | +5x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1) |
||
| 225 | +489 |
- #'+ } |
||
| 226 | +490 |
- #' @return+ |
||
| 227 | -+ | |||
| 491 | +5x |
- #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions,+ if (!as_list) {
|
||
| 228 | +492 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ # align plot and table |
||
| 229 | -+ | |||
| 493 | +4x |
- #' the statistics from `s_ancova()` to the table layout.+ cowplot::plot_grid(+ |
+ ||
| 494 | +4x | +
+ p,+ |
+ ||
| 495 | +4x | +
+ tbl,+ |
+ ||
| 496 | +4x | +
+ ncol = 1,+ |
+ ||
| 497 | +4x | +
+ align = "v",+ |
+ ||
| 498 | +4x | +
+ axis = "tblr",+ |
+ ||
| 499 | +4x | +
+ rel_heights = c(rel_height_plot, 1 - rel_height_plot) |
||
| 230 | +500 |
- #'+ ) |
||
| 231 | +501 |
- #' @examples+ } else {
+ |
+ ||
| 502 | +1x | +
+ list(plot = p, table = tbl) |
||
| 232 | +503 |
- #' basic_table() %>%+ } |
||
| 233 | +504 |
- #' split_cols_by("Species", ref_group = "setosa") %>%
+ } else {
+ |
+ ||
| 505 | +8x | +
+ p |
||
| 234 | +506 |
- #' add_colcounts() %>%+ } |
||
| 235 | +507 |
- #' summarize_ancova(+ } |
||
| 236 | +508 |
- #' vars = "Petal.Length",+ |
||
| 237 | +509 |
- #' variables = list(arm = "Species", covariates = NULL),+ #' Helper function to format the optional `g_lineplot` table |
||
| 238 | +510 |
- #' table_names = "unadj",+ #' |
||
| 239 | +511 |
- #' conf_level = 0.95, var_labels = "Unadjusted comparison",+ #' @description `r lifecycle::badge("stable")`
|
||
| 240 | +512 |
- #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means")+ #' |
||
| 241 | +513 |
- #' ) %>%+ #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled. |
||
| 242 | +514 |
- #' summarize_ancova(+ #' Elements of `x` must be `numeric` vectors. |
||
| 243 | +515 |
- #' vars = "Petal.Length",+ #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must |
||
| 244 | +516 |
- #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
+ #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell` |
||
| 245 | +517 |
- #' table_names = "adj",+ #' function through the `format` parameter. |
||
| 246 | +518 |
- #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)"+ #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must |
||
| 247 | +519 |
- #' ) %>%+ #' match the names of `x`. When a label is not specified for an element of `x`, |
||
| 248 | +520 |
- #' build_table(iris)+ #' then this function tries to use `label` or `names` (in this order) attribute of that element |
||
| 249 | +521 |
- #'+ #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes |
||
| 250 | +522 |
- #' @export+ #' are attached to a given element of `x`, then the label is automatically generated. |
||
| 251 | +523 |
- #' @order 2+ #' |
||
| 252 | +524 |
- summarize_ancova <- function(lyt,+ #' @return A single row `data.frame` object. |
||
| 253 | +525 |
- vars,+ #' |
||
| 254 | +526 |
- variables,+ #' @examples |
||
| 255 | +527 |
- conf_level,+ #' mean_ci <- c(48, 51) |
||
| 256 | +528 |
- interaction_y = FALSE,+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 257 | +529 |
- interaction_item = NULL,+ #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)") |
||
| 258 | +530 |
- var_labels,+ #' labels <- c(mean = "My Mean") |
||
| 259 | +531 |
- na_str = default_na_str(),+ #' h_format_row(x, format, labels) |
||
| 260 | +532 |
- nested = TRUE,+ #' |
||
| 261 | +533 |
- ...,+ #' attr(mean_ci, "label") <- "Mean 95% CI" |
||
| 262 | +534 |
- show_labels = "visible",+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 263 | +535 |
- table_names = vars,+ #' h_format_row(x, format, labels) |
||
| 264 | +536 |
- .stats = NULL,+ #' |
||
| 265 | +537 |
- .formats = NULL,+ #' @export |
||
| 266 | +538 |
- .labels = NULL,+ h_format_row <- function(x, format, labels = NULL) {
|
||
| 267 | +539 |
- .indent_mods = NULL) {
+ # cell: one row, one column data.frame |
||
| 268 | -7x | +540 | +92x |
- extra_args <- list(+ format_cell <- function(x, format, label = NULL) {
|
| 269 | -7x | +541 | +238x |
- variables = variables, conf_level = conf_level, interaction_y = interaction_y,+ fc <- format_rcell(x = x, format = unlist(format)) |
| 270 | -7x | +542 | +238x |
- interaction_item = interaction_item, ...+ if (is.na(fc)) {
|
| 271 | -+ | |||
| 543 | +! |
- )+ fc <- "NA" |
||
| 272 | +544 |
-
+ } |
||
| 273 | -7x | +545 | +238x |
- afun <- make_afun(+ x_label <- attr(x, "label") |
| 274 | -7x | +546 | +238x |
- a_ancova,+ if (!is.null(label) && !is.na(label)) {
|
| 275 | -7x | +547 | +236x |
- interaction_y = interaction_y,+ names(fc) <- label |
| 276 | -7x | +548 | +2x |
- interaction_item = interaction_item,+ } else if (!is.null(x_label) && !is.na(x_label)) {
|
| 277 | -7x | +549 | +1x |
- .stats = .stats,+ names(fc) <- x_label |
| 278 | -7x | +550 | +1x |
- .formats = .formats,+ } else if (length(x) == length(fc)) {
|
| 279 | -7x | +|||
| 551 | +! |
- .labels = .labels,+ names(fc) <- names(x)+ |
+ ||
| 552 | ++ |
+ } |
||
| 280 | -7x | +553 | +238x |
- .indent_mods = .indent_mods+ as.data.frame(t(fc)) |
| 281 | +554 |
- )+ } |
||
| 282 | +555 | |||
| 283 | -7x | -
- analyze(- |
- ||
| 284 | -7x | -
- lyt,- |
- ||
| 285 | -7x | +556 | +92x |
- vars,+ row <- do.call( |
| 286 | -7x | +557 | +92x |
- var_labels = var_labels,+ cbind, |
| 287 | -7x | +558 | +92x |
- show_labels = show_labels,+ lapply( |
| 288 | -7x | +559 | +92x |
- table_names = table_names,+ names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn]) |
| 289 | -7x | +|||
| 560 | +
- afun = afun,+ ) |
|||
| 290 | -7x | +|||
| 561 | +
- na_str = na_str,+ ) |
|||
| 291 | -7x | +|||
| 562 | +
- nested = nested,+ |
|||
| 292 | -7x | +563 | +92x |
- extra_args = extra_args+ row |
| 293 | +564 |
- )+ } |
||
| 294 | +565 |
- }+ |
| 1 | +566 |
- #' Encode categorical missing values in a data frame+ #' Control function for `g_lineplot()` |
|
| 2 | +567 |
#' |
|
| 3 | +568 |
#' @description `r lifecycle::badge("stable")`
|
|
| 4 | +569 |
#' |
|
| 5 | +570 |
- #' This is a helper function to encode missing entries across groups of categorical+ #' Default values for `variables` parameter in `g_lineplot` function. |
|
| 6 | +571 |
- #' variables in a data frame.+ #' A variable's default value can be overwritten for any variable. |
|
| 7 | +572 |
#' |
|
| 8 | +573 |
- #' @details Missing entries are those with `NA` or empty strings and will+ #' @param x (`string`)\cr x-variable name. |
|
| 9 | +574 |
- #' be replaced with a specified value. If factor variables include missing+ #' @param y (`string`)\cr y-variable name. |
|
| 10 | +575 |
- #' values, the missing value will be inserted as the last level.+ #' @param group_var (`string` or `NA`)\cr group variable name. |
|
| 11 | +576 |
- #' Similarly, in case character or logical variables should be converted to factors+ #' @param subject_var (`string` or `NA`)\cr subject variable name. |
|
| 12 | +577 |
- #' with the `char_as_factor` or `logical_as_factor` options, the missing values will+ #' @param facet_var (`string` or `NA`)\cr faceting variable name. |
|
| 13 | +578 |
- #' be set as the last level.+ #' @param paramcd (`string` or `NA`)\cr parameter code variable name. |
|
| 14 | +579 |
- #'+ #' @param y_unit (`string` or `NA`)\cr y-axis unit variable name. |
|
| 15 | +580 |
- #' @param data (`data.frame`)\cr data set.+ #' |
|
| 16 | +581 |
- #' @param omit_columns (`character`)\cr names of variables from `data` that should+ #' @return A named character vector of variable names. |
|
| 17 | +582 |
- #' not be modified by this function.+ #' |
|
| 18 | +583 |
- #' @param char_as_factor (`flag`)\cr whether to convert character variables+ #' @examples |
|
| 19 | +584 |
- #' in `data` to factors.+ #' control_lineplot_vars() |
|
| 20 | +585 |
- #' @param logical_as_factor (`flag`)\cr whether to convert logical variables+ #' control_lineplot_vars(group_var = NA) |
|
| 21 | +586 |
- #' in `data` to factors.+ #' |
|
| 22 | +587 |
- #' @param na_level (`string`)\cr string used to replace all `NA` or empty+ #' @export |
|
| 23 | +588 |
- #' values inside non-`omit_columns` columns.+ control_lineplot_vars <- function(x = "AVISIT", |
|
| 24 | +589 |
- #'+ y = "AVAL", |
|
| 25 | +590 |
- #' @return A `data.frame` with the chosen modifications applied.+ group_var = "ARM", |
|
| 26 | +591 |
- #'+ facet_var = NA, |
|
| 27 | +592 |
- #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions.+ paramcd = "PARAMCD", |
|
| 28 | +593 |
- #'+ y_unit = "AVALU", |
|
| 29 | +594 |
- #' @examples+ subject_var = "USUBJID") {
|
|
| 30 | -+ | ||
| 595 | +16x |
- #' my_data <- data.frame(+ checkmate::assert_string(x) |
|
| 31 | -+ | ||
| 596 | +16x |
- #' u = c(TRUE, FALSE, NA, TRUE),+ checkmate::assert_string(y) |
|
| 32 | -+ | ||
| 597 | +16x |
- #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
+ checkmate::assert_string(group_var, na.ok = TRUE, null.ok = TRUE) |
|
| 33 | -+ | ||
| 598 | +16x |
- #' w = c("A", "B", NA, "C"),
+ checkmate::assert_string(facet_var, na.ok = TRUE, null.ok = TRUE) |
|
| 34 | -+ | ||
| 599 | +16x |
- #' x = c("D", "E", "F", NA),
+ checkmate::assert_string(subject_var, na.ok = TRUE, null.ok = TRUE) |
|
| 35 | -+ | ||
| 600 | +16x |
- #' y = c("G", "H", "I", ""),
+ checkmate::assert_string(paramcd, na.ok = TRUE, null.ok = TRUE) |
|
| 36 | -+ | ||
| 601 | +16x |
- #' z = c(1, 2, 3, 4),+ checkmate::assert_string(y_unit, na.ok = TRUE, null.ok = TRUE) |
|
| 37 | +602 |
- #' stringsAsFactors = FALSE+ |
|
| 38 | -+ | ||
| 603 | +16x |
- #' )+ variables <- c( |
|
| 39 | -+ | ||
| 604 | +16x |
- #'+ x = x, y = y, group_var = group_var, paramcd = paramcd, |
|
| 40 | -+ | ||
| 605 | +16x |
- #' # Example 1+ y_unit = y_unit, subject_var = subject_var, facet_var = facet_var |
|
| 41 | +606 |
- #' # Encode missing values in all character or factor columns.+ ) |
|
| 42 | -+ | ||
| 607 | +16x |
- #' df_explicit_na(my_data)+ return(variables) |
|
| 43 | +608 |
- #' # Also convert logical columns to factor columns.+ } |
| 44 | +1 |
- #' df_explicit_na(my_data, logical_as_factor = TRUE)+ #' Helper functions for subgroup treatment effect pattern (STEP) calculations |
||
| 45 | +2 |
- #' # Encode missing values in a subset of columns.+ #' |
||
| 46 | +3 |
- #' df_explicit_na(my_data, omit_columns = c("x", "y"))
+ #' @description `r lifecycle::badge("stable")`
|
||
| 47 | +4 |
#' |
||
| 48 | +5 |
- #' # Example 2+ #' Helper functions that are used internally for the STEP calculations. |
||
| 49 | +6 |
- #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable.+ #' |
||
| 50 | +7 |
- #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not+ #' @inheritParams argument_convention |
||
| 51 | +8 |
- #' # included when generating `rtables`.+ #' |
||
| 52 | +9 |
- #' adsl <- tern_ex_adsl+ #' @name h_step |
||
| 53 | +10 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ #' @include control_step.R |
||
| 54 | +11 |
- #' adsl <- df_explicit_na(adsl)+ NULL |
||
| 55 | +12 |
- #'+ |
||
| 56 | +13 |
- #' # If you want the `Na` values to be displayed in the table use the `na_level` argument.+ #' @describeIn h_step Creates the windows for STEP, based on the control settings |
||
| 57 | +14 |
- #' adsl <- tern_ex_adsl+ #' provided. |
||
| 58 | +15 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ #' |
||
| 59 | +16 |
- #' adsl <- df_explicit_na(adsl, na_level = "Missing Values")+ #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`). |
||
| 60 | +17 |
- #'+ #' @param control (named `list`)\cr output from `control_step()`. |
||
| 61 | +18 |
- #' # Example 3+ #' |
||
| 62 | +19 |
- #' # Numeric variables that have missing values are not altered. This means that any `NA` value in+ #' @return |
||
| 63 | +20 |
- #' # a numeric variable will not be included in the summary statistics, nor will they be included+ #' * `h_step_window()` returns a list containing the window-selection matrix `sel` |
||
| 64 | +21 |
- #' # in the denominator value for calculating the percent values.+ #' and the interval information matrix `interval`. |
||
| 65 | +22 |
- #' adsl <- tern_ex_adsl+ #' |
||
| 66 | +23 |
- #' adsl$AGE[adsl$AGE < 30] <- NA+ #' @export |
||
| 67 | +24 |
- #' adsl <- df_explicit_na(adsl)+ h_step_window <- function(x, |
||
| 68 | +25 |
- #'+ control = control_step()) {
|
||
| 69 | -+ | |||
| 26 | +12x |
- #' @export+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
||
| 70 | -+ | |||
| 27 | +12x |
- df_explicit_na <- function(data,+ checkmate::assert_list(control, names = "named") |
||
| 71 | +28 |
- omit_columns = NULL,+ |
||
| 72 | -- |
- char_as_factor = TRUE,- |
- ||
| 73 | -+ | |||
| 29 | +12x |
- logical_as_factor = FALSE,+ sel <- matrix(FALSE, length(x), control$num_points) |
||
| 74 | -+ | |||
| 30 | +12x |
- na_level = "<Missing>") {
+ out <- matrix(0, control$num_points, 3) |
||
| 75 | -24x | +31 | +12x |
- checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)+ colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
|
| 76 | -23x | +32 | +12x |
- checkmate::assert_data_frame(data)+ if (control$use_percentile) {
|
| 77 | -22x | +|||
| 33 | +
- checkmate::assert_flag(char_as_factor)+ # Create windows according to percentile cutoffs. |
|||
| 78 | -21x | +34 | +9x |
- checkmate::assert_flag(logical_as_factor)+ out <- cbind(out, out) |
| 79 | -21x | +35 | +9x |
- checkmate::assert_string(na_level)+ colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
|
| 80 | -+ | |||
| 36 | +9x |
-
+ xs <- seq(0, 1, length.out = control$num_points + 2)[-1] |
||
| 81 | -19x | +37 | +9x |
- target_vars <- if (is.null(omit_columns)) {
+ for (i in seq_len(control$num_points)) {
|
| 82 | -17x | +38 | +185x |
- names(data)+ out[i, 2:3] <- c( |
| 83 | -+ | |||
| 39 | +185x |
- } else {
+ max(xs[i] - control$bandwidth, 0), |
||
| 84 | -2x | +40 | +185x |
- setdiff(names(data), omit_columns) # May have duplicates.+ min(xs[i] + control$bandwidth, 1) |
| 85 | +41 |
- }+ ) |
||
| 86 | -19x | +42 | +185x |
- if (length(target_vars) == 0) {
+ out[i, 5:6] <- stats::quantile(x, out[i, 2:3]) |
| 87 | -1x | +43 | +185x |
- return(data)+ sel[, i] <- x >= out[i, 5] & x <= out[i, 6] |
| 88 | +44 |
- }+ } |
||
| 89 | +45 |
-
+ # Center is the middle point of the percentile window. |
||
| 90 | -18x | +46 | +9x |
- l_target_vars <- split(target_vars, target_vars)+ out[, 1] <- xs[-control$num_points - 1] |
| 91 | -+ | |||
| 47 | +9x |
-
+ out[, 4] <- stats::quantile(x, out[, 1]) |
||
| 92 | +48 |
- # Makes sure target_vars exist in data and names are not duplicated.- |
- ||
| 93 | -18x | -
- assert_df_with_variables(data, l_target_vars)+ } else {
|
||
| 94 | +49 |
-
+ # Create windows according to cutoffs. |
||
| 95 | -18x | +50 | +3x |
- for (x in target_vars) {
+ m <- c(min(x), max(x)) |
| 96 | -306x | +51 | +3x |
- xi <- data[[x]]+ xs <- seq(m[1], m[2], length.out = control$num_points + 2)[-1] |
| 97 | -306x | -
- xi_label <- obj_label(xi)- |
- ||
| 98 | -- | - - | -||
| 99 | -+ | 52 | +3x |
- # Determine whether to convert character or logical input.+ for (i in seq_len(control$num_points)) {
|
| 100 | -306x | +53 | +11x |
- do_char_conversion <- is.character(xi) && char_as_factor+ out[i, 2:3] <- c( |
| 101 | -306x | -
- do_logical_conversion <- is.logical(xi) && logical_as_factor- |
- ||
| 102 | -+ | 54 | +11x |
-
+ max(xs[i] - control$bandwidth, m[1]), |
| 103 | -+ | |||
| 55 | +11x |
- # Pre-convert logical to character to deal correctly with replacing NA+ min(xs[i] + control$bandwidth, m[2]) |
||
| 104 | +56 |
- # values below.- |
- ||
| 105 | -306x | -
- if (do_logical_conversion) {
+ ) |
||
| 106 | -2x | +57 | +11x |
- xi <- as.character(xi)+ sel[, i] <- x >= out[i, 2] & x <= out[i, 3] |
| 107 | +58 |
} |
||
| 108 | +59 |
-
+ # Center is the same as the point for predicting. |
||
| 109 | -306x | +60 | +3x |
- if (is.factor(xi) || is.character(xi)) {
+ out[, 1] <- xs[-control$num_points - 1] |
| 110 | +61 |
- # Handle empty strings and NA values.+ } |
||
| 111 | -219x | +62 | +12x |
- xi <- explicit_na(sas_na(xi), label = na_level)+ list(sel = sel, interval = out) |
| 112 | +63 |
-
+ } |
||
| 113 | +64 |
- # Convert to factors if requested for the original type,+ |
||
| 114 | +65 |
- # set na_level as the last value.- |
- ||
| 115 | -219x | -
- if (do_char_conversion || do_logical_conversion) {
- |
- ||
| 116 | -78x | -
- levels_xi <- setdiff(sort(unique(xi)), na_level)- |
- ||
| 117 | -78x | -
- if (na_level %in% unique(xi)) {
- |
- ||
| 118 | -18x | -
- levels_xi <- c(levels_xi, na_level)+ #' @describeIn h_step Calculates the estimated treatment effect estimate |
||
| 119 | +66 |
- }+ #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted |
||
| 120 | +67 | - - | -||
| 121 | -78x | -
- xi <- factor(xi, levels = levels_xi)+ #' on `data` given `variables` specification, for a single biomarker value `x`. |
||
| 122 | +68 |
- }+ #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds |
||
| 123 | +69 | - - | -||
| 124 | -219x | -
- data[, x] <- formatters::with_label(xi, label = xi_label)+ #' ratio estimates. |
||
| 125 | +70 |
- }+ #' |
||
| 126 | +71 |
- }+ #' @param model (`coxph` or `glm`)\cr the regression model object. |
||
| 127 | -18x | +|||
| 72 | +
- return(data)+ #' |
|||
| 128 | +73 |
- }+ #' @return |
| 1 | +74 |
- #' Analyze numeric variables in columns+ #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`. |
||
| 2 | +75 |
#' |
||
| 3 | +76 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @export |
||
| 4 | +77 |
- #'+ h_step_trt_effect <- function(data, |
||
| 5 | +78 |
- #' The layout-creating function [analyze_vars_in_cols()] creates a layout element to generate a column-wise+ model, |
||
| 6 | +79 |
- #' analysis table.+ variables, |
||
| 7 | +80 |
- #'+ x) {
|
||
| 8 | -+ | |||
| 81 | +208x |
- #' This function sets the analysis methods as column labels and is a wrapper for [rtables::analyze_colvars()].+ checkmate::assert_multi_class(model, c("coxph", "glm"))
|
||
| 9 | -+ | |||
| 82 | +208x |
- #' It was designed principally for PK tables.+ checkmate::assert_number(x) |
||
| 10 | -+ | |||
| 83 | +208x |
- #'+ assert_df_with_variables(data, variables) |
||
| 11 | -+ | |||
| 84 | +208x |
- #' @inheritParams argument_convention+ checkmate::assert_factor(data[[variables$arm]], n.levels = 2) |
||
| 12 | +85 |
- #' @inheritParams rtables::analyze_colvars+ |
||
| 13 | -+ | |||
| 86 | +208x |
- #' @param imp_rule (`string` or `NULL`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can+ newdata <- data[c(1, 1), ] |
||
| 14 | -+ | |||
| 87 | +208x |
- #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order+ newdata[, variables$biomarker] <- x |
||
| 15 | -+ | |||
| 88 | +208x |
- #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()]+ newdata[, variables$arm] <- levels(data[[variables$arm]]) |
||
| 16 | -+ | |||
| 89 | +208x |
- #' for more details on imputation.+ model_terms <- stats::delete.response(stats::terms(model)) |
||
| 17 | -+ | |||
| 90 | +208x |
- #' @param avalcat_var (`string`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a+ model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels) |
||
| 18 | -+ | |||
| 91 | +208x |
- #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of+ mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts) |
||
| 19 | -+ | |||
| 92 | +208x |
- #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable+ coefs <- stats::coef(model) |
||
| 20 | +93 |
- #' used to calculate the `n_blq` statistic (if included in `.stats`).+ # Note: It is important to use the coef subset from matrix, otherwise intercept and |
||
| 21 | +94 |
- #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will+ # strata are included for coxph() models. |
||
| 22 | -+ | |||
| 95 | +208x |
- #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is+ mat <- mat[, names(coefs)] |
||
| 23 | -+ | |||
| 96 | +208x |
- #' used for multiple tables with different data. Defaults to `FALSE`.+ mat_diff <- diff(mat) |
||
| 24 | -+ | |||
| 97 | +208x |
- #' @param row_labels (`character`)\cr as this function works in columns space, usually `.labels`+ est <- mat_diff %*% coefs |
||
| 25 | -+ | |||
| 98 | +208x |
- #' character vector applies on the column space. You can change the row labels by defining this+ var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff) |
||
| 26 | -+ | |||
| 99 | +208x |
- #' parameter to a named character vector with names corresponding to the split values. It defaults+ se <- sqrt(var) |
||
| 27 | -+ | |||
| 100 | +208x |
- #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label.+ c( |
||
| 28 | -+ | |||
| 101 | +208x |
- #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current+ est = est, |
||
| 29 | -+ | |||
| 102 | +208x |
- #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr`+ se = se |
||
| 30 | +103 |
- #' to define row labels. This behavior is not supported as we never need to overload row labels.+ ) |
||
| 31 | +104 |
- #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns.+ } |
||
| 32 | +105 |
- #' This option allows you to add multiple instances of this functions, also in a nested fashion,+ |
||
| 33 | +106 |
- #' without adding more splits. This split must happen only one time on a single layout.+ #' @describeIn h_step Builds the model formula used in survival STEP calculations. |
||
| 34 | +107 |
#' |
||
| 35 | +108 |
#' @return |
||
| 36 | +109 |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' * `h_step_survival_formula()` returns a model formula. |
||
| 37 | +110 |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ #' |
||
| 38 | +111 |
- #' in columns, and add it to the table layout.+ #' @export |
||
| 39 | +112 |
- #'+ h_step_survival_formula <- function(variables, |
||
| 40 | +113 |
- #' @note+ control = control_step()) {
|
||
| 41 | -+ | |||
| 114 | +10x |
- #' * This is an experimental implementation of [rtables::summarize_row_groups()] and [rtables::analyze_colvars()]+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
||
| 42 | +115 |
- #' that may be subjected to changes as `rtables` extends its support to more complex analysis pipelines in the+ |
||
| 43 | -+ | |||
| 116 | +10x |
- #' column space. We encourage users to read the examples carefully and file issues for different use cases.+ assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
|
||
| 44 | -+ | |||
| 117 | +10x |
- #' * In this function, `labelstr` behaves atypically. If `labelstr = NULL` (the default), row labels are assigned+ form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
|
||
| 45 | -+ | |||
| 118 | +10x |
- #' automatically as the split values if `do_summarize_row_groups = FALSE` (the default), and as the group label+ if (control$degree > 0) {
|
||
| 46 | -+ | |||
| 119 | +5x |
- #' if `do_summarize_row_groups = TRUE`.+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
|
||
| 47 | +120 |
- #'+ } |
||
| 48 | -+ | |||
| 121 | +10x |
- #' @seealso [analyze_vars()], [rtables::analyze_colvars()].+ if (!is.null(variables$covariates)) {
|
||
| 49 | -+ | |||
| 122 | +6x |
- #'+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
||
| 50 | +123 |
- #' @examples+ } |
||
| 51 | -+ | |||
| 124 | +10x |
- #' library(dplyr)+ if (!is.null(variables$strata)) {
|
||
| 52 | -+ | |||
| 125 | +2x |
- #'+ form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
||
| 53 | +126 |
- #' # Data preparation+ } |
||
| 54 | -+ | |||
| 127 | +10x |
- #' adpp <- tern_ex_adpp %>% h_pkparam_sort()+ stats::as.formula(form) |
||
| 55 | +128 |
- #'+ } |
||
| 56 | +129 |
- #' lyt <- basic_table() %>%+ |
||
| 57 | +130 |
- #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>%+ #' @describeIn h_step Estimates the model with `formula` built based on |
||
| 58 | +131 |
- #' split_rows_by(+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
||
| 59 | +132 |
- #' var = "SEX",+ #' Cox regression. |
||
| 60 | +133 |
- #' label_pos = "topleft",+ #' |
||
| 61 | +134 |
- #' child_labels = "hidden"+ #' @param formula (`formula`)\cr the regression model formula. |
||
| 62 | +135 |
- #' ) %>% # Removes duplicated labels+ #' @param subset (`logical`)\cr subset vector. |
||
| 63 | +136 |
- #' analyze_vars_in_cols(vars = "AGE")+ #' |
||
| 64 | +137 |
- #' result <- build_table(lyt = lyt, df = adpp)+ #' @return |
||
| 65 | +138 |
- #' result+ #' * `h_step_survival_est()` returns a matrix of number of observations `n`, |
||
| 66 | +139 |
- #'+ #' `events`, log hazard ratio estimates `loghr`, standard error `se`, |
||
| 67 | +140 |
- #' # By selecting just some statistics and ad-hoc labels+ #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is |
||
| 68 | +141 |
- #' lyt <- basic_table() %>%+ #' included for each biomarker value in `x`. |
||
| 69 | +142 |
- #' split_rows_by(var = "ARM", label_pos = "topleft") %>%+ #' |
||
| 70 | +143 |
- #' split_rows_by(+ #' @export |
||
| 71 | +144 |
- #' var = "SEX",+ h_step_survival_est <- function(formula, |
||
| 72 | +145 |
- #' label_pos = "topleft",+ data, |
||
| 73 | +146 |
- #' child_labels = "hidden",+ variables, |
||
| 74 | +147 |
- #' split_fun = drop_split_levels+ x, |
||
| 75 | +148 |
- #' ) %>%+ subset = rep(TRUE, nrow(data)), |
||
| 76 | +149 |
- #' analyze_vars_in_cols(+ control = control_coxph()) {
|
||
| 77 | -+ | |||
| 150 | +55x |
- #' vars = "AGE",+ checkmate::assert_formula(formula) |
||
| 78 | -+ | |||
| 151 | +55x |
- #' .stats = c("n", "cv", "geom_mean"),
+ assert_df_with_variables(data, variables) |
||
| 79 | -+ | |||
| 152 | +55x |
- #' .labels = c(+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
||
| 80 | -+ | |||
| 153 | +55x |
- #' n = "aN",+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
||
| 81 | -+ | |||
| 154 | +55x |
- #' cv = "aCV",+ checkmate::assert_list(control, names = "named") |
||
| 82 | +155 |
- #' geom_mean = "aGeomMean"+ |
||
| 83 | +156 |
- #' )+ # Note: `subset` in `coxph` needs to be an expression referring to `data` variables. |
||
| 84 | -+ | |||
| 157 | +55x |
- #' )+ data$.subset <- subset |
||
| 85 | -+ | |||
| 158 | +55x |
- #' result <- build_table(lyt = lyt, df = adpp)+ coxph_warnings <- NULL |
||
| 86 | -+ | |||
| 159 | +55x |
- #' result+ tryCatch( |
||
| 87 | -+ | |||
| 160 | +55x |
- #'+ withCallingHandlers( |
||
| 88 | -+ | |||
| 161 | +55x |
- #' # Changing row labels+ expr = {
|
||
| 89 | -+ | |||
| 162 | +55x |
- #' lyt <- basic_table() %>%+ fit <- survival::coxph( |
||
| 90 | -+ | |||
| 163 | +55x |
- #' analyze_vars_in_cols(+ formula = formula, |
||
| 91 | -+ | |||
| 164 | +55x |
- #' vars = "AGE",+ data = data, |
||
| 92 | -+ | |||
| 165 | +55x |
- #' row_labels = "some custom label"+ subset = .subset, |
||
| 93 | -+ | |||
| 166 | +55x |
- #' )+ ties = control$ties |
||
| 94 | +167 |
- #' result <- build_table(lyt, df = adpp)+ ) |
||
| 95 | +168 |
- #' result+ }, |
||
| 96 | -+ | |||
| 169 | +55x |
- #'+ warning = function(w) {
|
||
| 97 | -+ | |||
| 170 | +1x |
- #' # Pharmacokinetic parameters+ coxph_warnings <<- c(coxph_warnings, w) |
||
| 98 | -+ | |||
| 171 | +1x |
- #' lyt <- basic_table() %>%+ invokeRestart("muffleWarning")
|
||
| 99 | +172 |
- #' split_rows_by(+ } |
||
| 100 | +173 |
- #' var = "TLG_DISPLAY",+ ), |
||
| 101 | -+ | |||
| 174 | +55x |
- #' split_label = "PK Parameter",+ finally = {
|
||
| 102 | +175 |
- #' label_pos = "topleft",+ } |
||
| 103 | +176 |
- #' child_labels = "hidden"+ ) |
||
| 104 | -+ | |||
| 177 | +55x |
- #' ) %>%+ if (!is.null(coxph_warnings)) {
|
||
| 105 | -+ | |||
| 178 | +1x |
- #' analyze_vars_in_cols(+ warning(paste( |
||
| 106 | -+ | |||
| 179 | +1x |
- #' vars = "AVAL"+ "Fit warnings occurred, please consider using a simpler model, or", |
||
| 107 | -+ | |||
| 180 | +1x |
- #' )+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
||
| 108 | +181 |
- #' result <- build_table(lyt, df = adpp)+ )) |
||
| 109 | +182 |
- #' result+ } |
||
| 110 | +183 |
- #'+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
||
| 111 | -+ | |||
| 184 | +55x |
- #' # Multiple calls (summarize label and analyze underneath)+ estimates <- t(vapply( |
||
| 112 | -+ | |||
| 185 | +55x |
- #' lyt <- basic_table() %>%+ X = x, |
||
| 113 | -+ | |||
| 186 | +55x |
- #' split_rows_by(+ FUN = h_step_trt_effect, |
||
| 114 | -+ | |||
| 187 | +55x |
- #' var = "TLG_DISPLAY",+ FUN.VALUE = c(1, 2), |
||
| 115 | -+ | |||
| 188 | +55x |
- #' split_label = "PK Parameter",+ data = data, |
||
| 116 | -+ | |||
| 189 | +55x |
- #' label_pos = "topleft"+ model = fit, |
||
| 117 | -+ | |||
| 190 | +55x |
- #' ) %>%+ variables = variables |
||
| 118 | +191 |
- #' analyze_vars_in_cols(+ )) |
||
| 119 | -+ | |||
| 192 | +55x |
- #' vars = "AVAL",+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
||
| 120 | -+ | |||
| 193 | +55x |
- #' do_summarize_row_groups = TRUE # does a summarize level+ cbind( |
||
| 121 | -+ | |||
| 194 | +55x |
- #' ) %>%+ n = fit$n, |
||
| 122 | -+ | |||
| 195 | +55x |
- #' split_rows_by("SEX",
+ events = fit$nevent, |
||
| 123 | -+ | |||
| 196 | +55x |
- #' child_labels = "hidden",+ loghr = estimates[, "est"], |
||
| 124 | -+ | |||
| 197 | +55x |
- #' label_pos = "topleft"+ se = estimates[, "se"],+ |
+ ||
| 198 | +55x | +
+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ |
+ ||
| 199 | +55x | +
+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
||
| 125 | +200 |
- #' ) %>%+ ) |
||
| 126 | +201 |
- #' analyze_vars_in_cols(+ } |
||
| 127 | +202 |
- #' vars = "AVAL",+ |
||
| 128 | +203 |
- #' split_col_vars = FALSE # avoids re-splitting the columns+ #' @describeIn h_step Builds the model formula used in response STEP calculations. |
||
| 129 | +204 |
- #' )+ #' |
||
| 130 | +205 |
- #' result <- build_table(lyt, df = adpp)+ #' @return |
||
| 131 | +206 |
- #' result+ #' * `h_step_rsp_formula()` returns a model formula. |
||
| 132 | +207 |
#' |
||
| 133 | +208 |
#' @export |
||
| 134 | +209 |
- analyze_vars_in_cols <- function(lyt,+ h_step_rsp_formula <- function(variables, |
||
| 135 | +210 |
- vars,+ control = c(control_step(), control_logistic())) {
|
||
| 136 | -+ | |||
| 211 | +14x |
- ...,+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
||
| 137 | -+ | |||
| 212 | +14x |
- .stats = c(+ assert_list_of_variables(variables[c("arm", "biomarker", "response")])
|
||
| 138 | -+ | |||
| 213 | +14x |
- "n",+ response_definition <- sub( |
||
| 139 | -+ | |||
| 214 | +14x |
- "mean",+ pattern = "response", |
||
| 140 | -+ | |||
| 215 | +14x |
- "sd",+ replacement = variables$response, |
||
| 141 | -+ | |||
| 216 | +14x |
- "se",+ x = control$response_definition, |
||
| 142 | -+ | |||
| 217 | +14x |
- "cv",+ fixed = TRUE |
||
| 143 | +218 |
- "geom_cv"+ ) |
||
| 144 | -+ | |||
| 219 | +14x |
- ),+ form <- paste0(response_definition, " ~ ", variables$arm) |
||
| 145 | -+ | |||
| 220 | +14x |
- .labels = c(+ if (control$degree > 0) {
|
||
| 146 | -+ | |||
| 221 | +8x |
- n = "n",+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
|
||
| 147 | +222 |
- mean = "Mean",+ } |
||
| 148 | -+ | |||
| 223 | +14x |
- sd = "SD",+ if (!is.null(variables$covariates)) {
+ |
+ ||
| 224 | +8x | +
+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
||
| 149 | +225 |
- se = "SE",+ }+ |
+ ||
| 226 | +14x | +
+ if (!is.null(variables$strata)) {
+ |
+ ||
| 227 | +5x | +
+ strata_arg <- if (length(variables$strata) > 1) {
+ |
+ ||
| 228 | +2x | +
+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
||
| 150 | +229 |
- cv = "CV (%)",+ } else {
+ |
+ ||
| 230 | +3x | +
+ variables$strata |
||
| 151 | +231 |
- geom_cv = "CV % Geometric Mean"+ }+ |
+ ||
| 232 | +5x | +
+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
||
| 152 | +233 |
- ),+ }+ |
+ ||
| 234 | +14x | +
+ stats::as.formula(form) |
||
| 153 | +235 |
- row_labels = NULL,+ } |
||
| 154 | +236 |
- do_summarize_row_groups = FALSE,+ |
||
| 155 | +237 |
- split_col_vars = TRUE,+ #' @describeIn h_step Estimates the model with `formula` built based on |
||
| 156 | +238 |
- imp_rule = NULL,+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
||
| 157 | +239 |
- avalcat_var = "AVALCAT1",+ #' logistic regression. |
||
| 158 | +240 |
- cache = FALSE,+ #' |
||
| 159 | +241 |
- .indent_mods = NULL,+ #' @param formula (`formula`)\cr the regression model formula. |
||
| 160 | +242 |
- na_str = default_na_str(),+ #' @param subset (`logical`)\cr subset vector. |
||
| 161 | +243 |
- nested = TRUE,+ #' |
||
| 162 | +244 |
- .formats = NULL,+ #' @return |
||
| 163 | +245 |
- .aligns = NULL) {
+ #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds |
||
| 164 | -26x | +|||
| 246 | +
- extra_args <- list(...)+ #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds |
|||
| 165 | +247 |
-
+ #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`. |
||
| 166 | -26x | +|||
| 248 | +
- checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE)+ #' |
|||
| 167 | -26x | +|||
| 249 | +
- checkmate::assert_character(row_labels, null.ok = TRUE)+ #' @export |
|||
| 168 | -26x | +|||
| 250 | +
- checkmate::assert_int(.indent_mods, null.ok = TRUE)+ h_step_rsp_est <- function(formula, |
|||
| 169 | -26x | +|||
| 251 | +
- checkmate::assert_flag(nested)+ data, |
|||
| 170 | -26x | +|||
| 252 | +
- checkmate::assert_flag(split_col_vars)+ variables, |
|||
| 171 | -26x | +|||
| 253 | +
- checkmate::assert_flag(do_summarize_row_groups)+ x, |
|||
| 172 | +254 |
-
+ subset = rep(TRUE, nrow(data)), |
||
| 173 | +255 |
- # Filtering+ control = control_logistic()) {
|
||
| 174 | -26x | +256 | +58x |
- met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
+ checkmate::assert_formula(formula) |
| 175 | -26x | +257 | +58x |
- .stats <- get_stats(met_grps, stats_in = .stats)+ assert_df_with_variables(data, variables) |
| 176 | -26x | +258 | +58x |
- formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
| 177 | -26x | +259 | +58x |
- labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels)+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
| 178 | -! | +|||
| 260 | +58x |
- if ("control" %in% names(extra_args)) labels_v <- labels_v %>% labels_use_control(extra_args[["control"]], .labels)
+ checkmate::assert_list(control, names = "named") |
||
| 179 | +261 |
-
+ # Note: `subset` in `glm` needs to be an expression referring to `data` variables. |
||
| 180 | -+ | |||
| 262 | +58x |
- # Check for vars in the case that one or more are used+ data$.subset <- subset |
||
| 181 | -26x | +263 | +58x |
- if (length(vars) == 1) {
+ fit_warnings <- NULL |
| 182 | -21x | +264 | +58x |
- vars <- rep(vars, length(.stats))+ tryCatch( |
| 183 | -5x | +265 | +58x |
- } else if (length(vars) != length(.stats)) {
+ withCallingHandlers( |
| 184 | -1x | +266 | +58x |
- stop(+ expr = {
|
| 185 | -1x | +267 | +58x |
- "Analyzed variables (vars) does not have the same ",+ fit <- if (is.null(variables$strata)) {
|
| 186 | -1x | +268 | +54x |
- "number of elements of specified statistics (.stats)."+ stats::glm( |
| 187 | -+ | |||
| 269 | +54x |
- )+ formula = formula, |
||
| 188 | -+ | |||
| 270 | +54x |
- }+ data = data, |
||
| 189 | -+ | |||
| 271 | +54x |
-
+ subset = .subset, |
||
| 190 | -25x | +272 | +54x |
- if (split_col_vars) {
+ family = stats::binomial("logit")
|
| 191 | +273 |
- # Checking there is not a previous identical column split+ ) |
||
| 192 | -21x | +|||
| 274 | +
- clyt <- tail(clayout(lyt), 1)[[1]]+ } else {
|
|||
| 193 | +275 |
-
+ # clogit needs coxph and strata imported |
||
| 194 | -21x | +276 | +4x |
- dummy_lyt <- split_cols_by_multivar(+ survival::clogit( |
| 195 | -21x | +277 | +4x |
- lyt = basic_table(),+ formula = formula, |
| 196 | -21x | +278 | +4x |
- vars = vars,+ data = data, |
| 197 | -21x | +279 | +4x |
- varlabels = labels_v+ subset = .subset |
| 198 | +280 |
- )+ ) |
||
| 199 | +281 | - - | -||
| 200 | -21x | -
- if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
+ } |
||
| 201 | -2x | +|||
| 282 | +
- stop(+ }, |
|||
| 202 | -2x | +283 | +58x |
- "Column split called again with the same values. ",+ warning = function(w) {
|
| 203 | -2x | +284 | +19x |
- "This can create many unwanted columns. Please consider adding ",+ fit_warnings <<- c(fit_warnings, w) |
| 204 | -2x | +285 | +19x |
- "split_col_vars = FALSE to the last call of ",+ invokeRestart("muffleWarning")
|
| 205 | -2x | +|||
| 286 | +
- deparse(sys.calls()[[sys.nframe() - 1]]), "."+ } |
|||
| 206 | +287 |
- )+ ), |
||
| 207 | -+ | |||
| 288 | +58x |
- }+ finally = {
|
||
| 208 | +289 |
-
+ } |
||
| 209 | +290 |
- # Main col split+ ) |
||
| 210 | -19x | +291 | +58x |
- lyt <- split_cols_by_multivar(+ if (!is.null(fit_warnings)) {
|
| 211 | -19x | +292 | +13x |
- lyt = lyt,+ warning(paste( |
| 212 | -19x | +293 | +13x |
- vars = vars,+ "Fit warnings occurred, please consider using a simpler model, or", |
| 213 | -19x | +294 | +13x |
- varlabels = labels_v+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
| 214 | +295 |
- )+ )) |
||
| 215 | +296 |
} |
||
| 216 | +297 |
-
+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
||
| 217 | -23x | +298 | +58x |
- env <- new.env() # create caching environment+ estimates <- t(vapply( |
| 218 | -+ | |||
| 299 | +58x |
-
+ X = x, |
||
| 219 | -23x | +300 | +58x |
- if (do_summarize_row_groups) {
+ FUN = h_step_trt_effect, |
| 220 | -8x | +301 | +58x |
- if (length(unique(vars)) > 1) {
+ FUN.VALUE = c(1, 2), |
| 221 | -! | +|||
| 302 | +58x |
- stop("When using do_summarize_row_groups only one label level var should be inserted.")
+ data = data, |
||
| 222 | -+ | |||
| 303 | +58x |
- }+ model = fit, |
||
| 223 | -+ | |||
| 304 | +58x |
-
+ variables = variables |
||
| 224 | +305 |
- # Function list for do_summarize_row_groups. Slightly different handling of labels+ )) |
||
| 225 | -8x | +306 | +58x |
- cfun_list <- Map(+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
| 226 | -8x | +307 | +58x |
- function(stat, use_cache, cache_env) {
+ cbind( |
| 227 | -48x | +308 | +58x |
- function(u, .spl_context, labelstr, .df_row, ...) {
+ n = length(fit$y), |
| 228 | -+ | |||
| 309 | +58x |
- # Statistic+ logor = estimates[, "est"], |
||
| 229 | -152x | +310 | +58x |
- var_row_val <- paste(+ se = estimates[, "se"], |
| 230 | -152x | +311 | +58x |
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
| 231 | -152x | +312 | +58x |
- paste(.spl_context$value, collapse = "_"),+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
| 232 | -152x | +|||
| 313 | +
- sep = "_"+ ) |
|||
| 233 | +314 |
- )+ } |
||
| 234 | -152x | +
| 1 | +
- if (use_cache) {
+ #' Cox proportional hazards regression |
|||
| 235 | -! | +|||
| 2 | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ #' |
|||
| 236 | -! | +|||
| 3 | +
- x_stats <- cache_env[[var_row_val]]+ #' @description `r lifecycle::badge("stable")`
|
|||
| 237 | +4 |
- } else {
+ #' |
||
| 238 | -152x | +|||
| 5 | +
- x_stats <- s_summary(u, ...)+ #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis. |
|||
| 239 | +6 |
- }+ #' |
||
| 240 | +7 |
-
+ #' @inheritParams argument_convention |
||
| 241 | -152x | +|||
| 8 | +
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 242 | -152x | +|||
| 9 | +
- res <- x_stats[[stat]]+ #' |
|||
| 243 | +10 |
- } else {
+ #' Options are: ``r shQuote(get_stats("summarize_coxreg"))``
|
||
| 244 | -! | +|||
| 11 | +
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ #' |
|||
| 245 | -! | +|||
| 12 | +
- res_imp <- imputation_rule(+ #' @details Cox models are the most commonly used methods to estimate the magnitude of |
|||
| 246 | -! | +|||
| 13 | +
- .df_row, x_stats, stat,+ #' the effect in survival analysis. It assumes proportional hazards: the ratio |
|||
| 247 | -! | +|||
| 14 | +
- imp_rule = imp_rule,+ #' of the hazards between groups (e.g., two arms) is constant over time. |
|||
| 248 | -! | +|||
| 15 | +
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ #' This ratio is referred to as the "hazard ratio" (HR) and is one of the |
|||
| 249 | -! | +|||
| 16 | +
- avalcat_var = avalcat_var+ #' most commonly reported metrics to describe the effect size in survival |
|||
| 250 | +17 |
- )+ #' analysis (NEST Team, 2020). |
||
| 251 | -! | +|||
| 18 | +
- res <- res_imp[["val"]]+ #' |
|||
| 252 | -! | +|||
| 19 | +
- na_str <- res_imp[["na_str"]]+ #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant |
|||
| 253 | +20 |
- }+ #' helper functions, and [tidy_coxreg] for custom tidy methods. |
||
| 254 | +21 |
-
+ #' |
||
| 255 | +22 |
- # Label check and replacement+ #' @examples |
||
| 256 | -152x | +|||
| 23 | +
- if (length(row_labels) > 1) {
+ #' library(survival) |
|||
| 257 | -32x | +|||
| 24 | +
- if (!(labelstr %in% names(row_labels))) {
+ #' |
|||
| 258 | -2x | +|||
| 25 | +
- stop(+ #' # Testing dataset [survival::bladder]. |
|||
| 259 | -2x | +|||
| 26 | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 260 | -2x | +|||
| 27 | +
- "that contains the split values. In the current split variable ",+ #' dta_bladder <- with( |
|||
| 261 | -2x | +|||
| 28 | +
- .spl_context$split[nrow(.spl_context)],+ #' data = bladder[bladder$enum < 5, ], |
|||
| 262 | -2x | +|||
| 29 | +
- " the labelstr value (split value by default) ", labelstr, " is not in",+ #' tibble::tibble( |
|||
| 263 | -2x | +|||
| 30 | +
- " row_labels names: ", names(row_labels)+ #' TIME = stop, |
|||
| 264 | +31 |
- )+ #' STATUS = event, |
||
| 265 | +32 |
- }+ #' ARM = as.factor(rx), |
||
| 266 | -30x | +|||
| 33 | +
- lbl <- unlist(row_labels[labelstr])+ #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
|
|||
| 267 | +34 |
- } else {
+ #' COVAR2 = factor( |
||
| 268 | -120x | +|||
| 35 | +
- lbl <- labelstr+ #' sample(as.factor(enum)), |
|||
| 269 | +36 |
- }+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 270 | +37 |
-
+ #' ) %>% formatters::with_label("Sex (F/M)")
|
||
| 271 | +38 |
- # Cell creation+ #' ) |
||
| 272 | -150x | +|||
| 39 | +
- rcell(res,+ #' ) |
|||
| 273 | -150x | +|||
| 40 | +
- label = lbl,+ #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|||
| 274 | -150x | -
- format = formats_v[names(formats_v) == stat][[1]],- |
- ||
| 275 | -150x | -
- format_na_str = na_str,- |
- ||
| 276 | -150x | +|||
| 41 | +
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ #' dta_bladder$STUDYID <- factor("X")
|
|||
| 277 | -150x | +|||
| 42 | +
- align = .aligns+ #' |
|||
| 278 | +43 |
- )+ #' u1_variables <- list( |
||
| 279 | +44 |
- }+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
||
| 280 | +45 |
- },+ #' ) |
||
| 281 | -8x | +|||
| 46 | +
- stat = .stats,+ #' |
|||
| 282 | -8x | +|||
| 47 | +
- use_cache = cache,+ #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
|||
| 283 | -8x | +|||
| 48 | +
- cache_env = replicate(length(.stats), env)+ #' |
|||
| 284 | +49 |
- )+ #' m1_variables <- list( |
||
| 285 | +50 |
-
+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
||
| 286 | +51 |
- # Main call to rtables+ #' ) |
||
| 287 | -8x | +|||
| 52 | +
- summarize_row_groups(+ #' |
|||
| 288 | -8x | +|||
| 53 | +
- lyt = lyt,+ #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
|||
| 289 | -8x | +|||
| 54 | +
- var = unique(vars),+ #' |
|||
| 290 | -8x | +|||
| 55 | +
- cfun = cfun_list,+ #' @name cox_regression |
|||
| 291 | -8x | +|||
| 56 | +
- na_str = na_str,+ #' @order 1 |
|||
| 292 | -8x | +|||
| 57 | +
- extra_args = extra_args+ NULL |
|||
| 293 | +58 |
- )+ |
||
| 294 | +59 |
- } else {
+ #' @describeIn cox_regression Statistics function that transforms results tabulated |
||
| 295 | +60 |
- # Function list for analyze_colvars+ #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list. |
||
| 296 | -15x | +|||
| 61 | +
- afun_list <- Map(+ #' |
|||
| 297 | -15x | +|||
| 62 | +
- function(stat, use_cache, cache_env) {
+ #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg] |
|||
| 298 | -76x | +|||
| 63 | +
- function(u, .spl_context, .df_row, ...) {
+ #' function with tidying applied via [broom::tidy()]. |
|||
| 299 | +64 |
- # Main statistics+ #' @param .stats (`character`)\cr the names of statistics to be reported among: |
||
| 300 | -468x | +|||
| 65 | +
- var_row_val <- paste(+ #' * `n`: number of observations (univariate only) |
|||
| 301 | -468x | +|||
| 66 | +
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ #' * `hr`: hazard ratio |
|||
| 302 | -468x | +|||
| 67 | +
- paste(.spl_context$value, collapse = "_"),+ #' * `ci`: confidence interval |
|||
| 303 | -468x | +|||
| 68 | +
- sep = "_"+ #' * `pval`: p-value of the treatment effect |
|||
| 304 | +69 |
- )+ #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only) |
||
| 305 | -468x | +|||
| 70 | +
- if (use_cache) {
+ #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model. |
|||
| 306 | -16x | +|||
| 71 | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ #' Defaults to `"all"`. Other options include `"var_main"` for main effects, `"inter"` for interaction effects, |
|||
| 307 | -56x | +|||
| 72 | +
- x_stats <- cache_env[[var_row_val]]+ #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is `"all"`, specific |
|||
| 308 | +73 |
- } else {
+ #' variables can be selected by specifying `.var_nms`. |
||
| 309 | -412x | +|||
| 74 | +
- x_stats <- s_summary(u, ...)+ #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically |
|||
| 310 | +75 |
- }+ #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired |
||
| 311 | +76 |
-
+ #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars` |
||
| 312 | -468x | +|||
| 77 | +
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ #' is `"var_main"`, `.var_nms` should be only the variable name. |
|||
| 313 | -348x | +|||
| 78 | +
- res <- x_stats[[stat]]+ #' |
|||
| 314 | +79 |
- } else {
+ #' @return |
||
| 315 | -120x | +|||
| 80 | +
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s). |
|||
| 316 | -120x | +|||
| 81 | +
- res_imp <- imputation_rule(+ #' |
|||
| 317 | -120x | +|||
| 82 | +
- .df_row, x_stats, stat,+ #' @examples |
|||
| 318 | -120x | +|||
| 83 | +
- imp_rule = imp_rule,+ #' # s_coxreg |
|||
| 319 | -120x | +|||
| 84 | +
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ #' |
|||
| 320 | -120x | +|||
| 85 | +
- avalcat_var = avalcat_var+ #' # Univariate |
|||
| 321 | +86 |
- )+ #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder) |
||
| 322 | -120x | +|||
| 87 | +
- res <- res_imp[["val"]]+ #' df1 <- broom::tidy(univar_model) |
|||
| 323 | -120x | +|||
| 88 | +
- na_str <- res_imp[["na_str"]]+ #' |
|||
| 324 | +89 |
- }+ #' s_coxreg(model_df = df1, .stats = "hr") |
||
| 325 | +90 |
-
+ #' |
||
| 326 | -468x | +|||
| 91 | +
- if (is.list(res)) {
+ #' # Univariate with interactions |
|||
| 327 | -19x | +|||
| 92 | +
- if (length(res) > 1) {
+ #' univar_model_inter <- fit_coxreg_univar( |
|||
| 328 | -1x | +|||
| 93 | +
- stop("The analyzed column produced more than one category of results.")
+ #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder |
|||
| 329 | +94 |
- } else {
+ #' ) |
||
| 330 | -18x | +|||
| 95 | +
- res <- unlist(res)+ #' df1_inter <- broom::tidy(univar_model_inter) |
|||
| 331 | +96 |
- }+ #' |
||
| 332 | +97 |
- }+ #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1") |
||
| 333 | +98 |
-
+ #' |
||
| 334 | +99 |
- # Label from context+ #' # Univariate without treatment arm - only "COVAR2" covariate effects |
||
| 335 | -467x | +|||
| 100 | +
- label_from_context <- .spl_context$value[nrow(.spl_context)]+ #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder) |
|||
| 336 | +101 |
-
+ #' df1_covs <- broom::tidy(univar_covs_model) |
||
| 337 | +102 |
- # Label switcher+ #' |
||
| 338 | -467x | +|||
| 103 | +
- if (is.null(row_labels)) {
+ #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
|
|||
| 339 | -387x | +|||
| 104 | +
- lbl <- label_from_context+ #' |
|||
| 340 | +105 |
- } else {
+ #' # Multivariate. |
||
| 341 | -80x | +|||
| 106 | +
- if (length(row_labels) > 1) {
+ #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder) |
|||
| 342 | -68x | +|||
| 107 | +
- if (!(label_from_context %in% names(row_labels))) {
+ #' df2 <- broom::tidy(multivar_model) |
|||
| 343 | -2x | +|||
| 108 | +
- stop(+ #' |
|||
| 344 | -2x | +|||
| 109 | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1") |
|||
| 345 | -2x | +|||
| 110 | +
- "that contains the split values. In the current split variable ",+ #' s_coxreg( |
|||
| 346 | -2x | +|||
| 111 | +
- .spl_context$split[nrow(.spl_context)],+ #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl", |
|||
| 347 | -2x | +|||
| 112 | +
- " the split value ", label_from_context, " is not in",+ #' .var_nms = c("COVAR1", "A Covariate Label")
|
|||
| 348 | -2x | +|||
| 113 | +
- " row_labels names: ", names(row_labels)+ #' ) |
|||
| 349 | +114 |
- )+ #' |
||
| 350 | +115 |
- }+ #' # Multivariate without treatment arm - only "COVAR1" main effect |
||
| 351 | -66x | +|||
| 116 | +
- lbl <- unlist(row_labels[label_from_context])+ #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder) |
|||
| 352 | +117 |
- } else {
+ #' df2_covs <- broom::tidy(multivar_covs_model) |
||
| 353 | -12x | +|||
| 118 | +
- lbl <- row_labels+ #' |
|||
| 354 | +119 |
- }+ #' s_coxreg(model_df = df2_covs, .stats = "hr") |
||
| 355 | +120 |
- }+ #' |
||
| 356 | +121 |
-
+ #' @export |
||
| 357 | +122 |
- # Cell creation+ s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
|
||
| 358 | -465x | +123 | +291x |
- rcell(res,+ assert_df_with_variables(model_df, list(term = "term", stat = .stats)) |
| 359 | -465x | +124 | +291x |
- label = lbl,+ checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
|
| 360 | -465x | +125 | +291x |
- format = formats_v[names(formats_v) == stat][[1]],+ model_df$term <- as.character(model_df$term) |
| 361 | -465x | +126 | +291x |
- format_na_str = na_str,+ .var_nms <- .var_nms[!is.na(.var_nms)]+ |
+
| 127 | ++ | + | ||
| 362 | -465x | +128 | +289x |
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ] |
| 363 | -465x | +129 | +69x |
- align = .aligns+ if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1) |
| 364 | +130 |
- )+ |
||
| 365 | +131 |
- }+ # We need a list with names corresponding to the stats to display of equal length to the list of stats.+ |
+ ||
| 132 | +291x | +
+ y <- split(model_df, f = model_df$term, drop = FALSE)+ |
+ ||
| 133 | +291x | +
+ y <- stats::setNames(y, nm = rep(.stats, length(y))) |
||
| 366 | +134 |
- },+ |
||
| 367 | -15x | +135 | +291x |
- stat = .stats,+ if (.which_vars == "var_main") {
|
| 368 | -15x | +136 | +128x |
- use_cache = cache,+ y <- lapply(y, function(x) x[1, ]) # only main effect |
| 369 | -15x | +137 | +163x |
- cache_env = replicate(length(.stats), env)+ } else if (.which_vars %in% c("inter", "multi_lvl")) {
|
| 370 | -+ | |||
| 138 | +120x |
- )+ y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect |
||
| 371 | +139 |
-
+ } |
||
| 372 | +140 |
- # Main call to rtables+ |
||
| 373 | -15x | +141 | +291x |
- analyze_colvars(lyt,+ lapply( |
| 374 | -15x | +142 | +291x |
- afun = afun_list,+ X = y, |
| 375 | -15x | +143 | +291x |
- na_str = na_str,+ FUN = function(x) {
|
| 376 | -15x | +144 | +295x |
- nested = nested,+ z <- as.list(x[[.stats]]) |
| 377 | -15x | +145 | +295x |
- extra_args = extra_args+ stats::setNames(z, nm = x$term_label) |
| 378 | +146 |
- )+ } |
||
| 379 | +147 |
- }+ ) |
||
| 380 | +148 |
} |
||
| 381 | +149 | |||
| 382 | +150 |
- # Helper function+ #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()] |
||
| 383 | +151 |
- get_last_col_split <- function(lyt) {
- |
- ||
| 384 | -3x | -
- tail(tail(clayout(lyt), 1)[[1]], 1)[[1]]+ #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`. |
||
| 385 | +152 |
- }+ #' |
| 1 | +153 |
- #' Count the number of patients with a particular event+ #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`. |
||
| 2 | +154 |
- #'+ #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`. |
||
| 3 | +155 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`. |
||
| 4 | +156 |
- #'+ #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to |
||
| 5 | +157 |
- #' The analyze function [count_patients_with_event()] creates a layout element to calculate patient counts for a+ #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching). |
||
| 6 | +158 |
- #' user-specified set of events.+ #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed |
||
| 7 | +159 |
- #'+ #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing |
||
| 8 | +160 |
- #' This function analyzes primary analysis variable `vars` which indicates unique subject identifiers. Events+ #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding |
||
| 9 | +161 |
- #' are defined by the user as a named vector via the `filters` argument, where each name corresponds to a+ #' effect estimates will be tabulated later. |
||
| 10 | +162 |
- #' variable and each value is the value(s) that that variable takes for the event.+ #' |
||
| 11 | +163 |
- #'+ #' @return |
||
| 12 | +164 |
- #' If there are multiple records with the same event recorded for a patient, only one occurrence is counted.+ #' * `a_coxreg()` returns formatted [rtables::CellValue()]. |
||
| 13 | +165 |
#' |
||
| 14 | +166 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 15 | +167 |
- #' @param filters (`character`)\cr a character vector specifying the column names and flag variables+ #' a_coxreg( |
||
| 16 | +168 |
- #' to be used for counting the number of unique identifiers satisfying such conditions.+ #' df = dta_bladder, |
||
| 17 | +169 |
- #' Multiple column names and flags are accepted in this format+ #' labelstr = "Label 1", |
||
| 18 | +170 |
- #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
+ #' variables = u1_variables, |
||
| 19 | +171 |
- #' Note that only equality is being accepted as condition.+ #' .spl_context = list(value = "COVAR1"), |
||
| 20 | +172 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' .stats = "n", |
||
| 21 | +173 |
- #'+ #' .formats = "xx" |
||
| 22 | +174 |
- #' Options are: ``r shQuote(get_stats("count_patients_with_event"))``
+ #' ) |
||
| 23 | +175 |
#' |
||
| 24 | +176 |
- #' @seealso [count_patients_with_flags()]+ #' a_coxreg( |
||
| 25 | +177 |
- #'+ #' df = dta_bladder, |
||
| 26 | +178 |
- #' @name count_patients_with_event+ #' labelstr = "", |
||
| 27 | +179 |
- #' @order 1+ #' variables = u1_variables, |
||
| 28 | +180 |
- NULL+ #' .spl_context = list(value = "COVAR2"), |
||
| 29 | +181 |
-
+ #' .stats = "pval", |
||
| 30 | +182 |
- #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which+ #' .formats = "xx.xxxx" |
||
| 31 | +183 |
- #' the defined event has occurred.+ #' ) |
||
| 32 | +184 |
#' |
||
| 33 | +185 |
- #' @inheritParams analyze_variables+ #' @export |
||
| 34 | +186 |
- #' @param .var (`string`)\cr name of the column that contains the unique identifier.+ a_coxreg <- function(df, |
||
| 35 | +187 |
- #'+ labelstr, |
||
| 36 | +188 |
- #' @return+ eff = FALSE, |
||
| 37 | +189 |
- #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event.+ var_main = FALSE, |
||
| 38 | +190 |
- #'+ multivar = FALSE, |
||
| 39 | +191 |
- #' @examples+ variables, |
||
| 40 | +192 |
- #' s_count_patients_with_event(+ at = list(), |
||
| 41 | +193 |
- #' tern_ex_adae,+ control = control_coxreg(), |
||
| 42 | +194 |
- #' .var = "SUBJID",+ .spl_context, |
||
| 43 | +195 |
- #' filters = c("TRTEMFL" = "Y")
+ .stats, |
||
| 44 | +196 |
- #' )+ .formats, |
||
| 45 | +197 |
- #'+ .indent_mods = NULL, |
||
| 46 | +198 |
- #' s_count_patients_with_event(+ na_str = "", |
||
| 47 | +199 |
- #' tern_ex_adae,+ cache_env = NULL) {
|
||
| 48 | -+ | |||
| 200 | +288x |
- #' .var = "SUBJID",+ cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm |
||
| 49 | -+ | |||
| 201 | +288x |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
+ cov <- tail(.spl_context$value, 1) # current variable/covariate |
||
| 50 | -+ | |||
| 202 | +288x |
- #' )+ var_lbl <- formatters::var_labels(df)[cov] # check for df labels |
||
| 51 | -+ | |||
| 203 | +288x |
- #'+ if (length(labelstr) > 1) {
|
||
| 52 | -+ | |||
| 204 | +8x |
- #' s_count_patients_with_event(+ labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none |
||
| 53 | -+ | |||
| 205 | +280x |
- #' tern_ex_adae,+ } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
|
||
| 54 | -+ | |||
| 206 | +67x |
- #' .var = "SUBJID",+ labelstr <- var_lbl |
||
| 55 | +207 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ } |
||
| 56 | -+ | |||
| 208 | +288x |
- #' denom = "N_col",+ if (eff || multivar || cov_no_arm) {
|
||
| 57 | -+ | |||
| 209 | +143x |
- #' .N_col = 456+ control$interaction <- FALSE |
||
| 58 | +210 |
- #' )+ } else {
|
||
| 59 | -+ | |||
| 211 | +145x |
- #'+ variables$covariates <- cov |
||
| 60 | -+ | |||
| 212 | +50x |
- #' @export+ if (var_main) control$interaction <- TRUE |
||
| 61 | +213 |
- s_count_patients_with_event <- function(df,+ } |
||
| 62 | +214 |
- .var,+ |
||
| 63 | -+ | |||
| 215 | +288x |
- filters,+ if (is.null(cache_env[[cov]])) {
|
||
| 64 | -+ | |||
| 216 | +47x |
- .N_col, # nolint+ if (!multivar) {
|
||
| 65 | -+ | |||
| 217 | +32x |
- .N_row, # nolint+ model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy() |
||
| 66 | +218 |
- denom = c("n", "N_col", "N_row")) {
+ } else {
|
||
| 67 | -51x | +219 | +15x |
- col_names <- names(filters)+ model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy()+ |
+
| 220 | ++ |
+ } |
||
| 68 | -51x | +221 | +47x |
- filter_values <- filters+ cache_env[[cov]] <- model |
| 69 | +222 |
-
+ } else {
|
||
| 70 | -51x | +223 | +241x |
- checkmate::assert_subset(col_names, colnames(df))+ model <- cache_env[[cov]] |
| 71 | +224 |
-
+ } |
||
| 72 | -51x | +225 | +148x |
- temp <- Map(+ if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_+ |
+
| 226 | ++ | + | ||
| 73 | -51x | +227 | +288x |
- function(x, y) which(df[[x]] == y),+ if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
|
| 74 | -51x | +228 | +15x |
- col_names,+ multivar <- TRUE |
| 75 | -51x | +229 | +3x |
- filter_values+ if (!cov_no_arm) var_main <- TRUE |
| 76 | +230 |
- )+ } |
||
| 77 | -51x | +|||
| 231 | +
- position_satisfy_filters <- Reduce(intersect, temp)+ |
|||
| 78 | -51x | +232 | +288x |
- id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]]))+ vars_coxreg <- list(which_vars = "all", var_nms = NULL) |
| 79 | -51x | +233 | +288x |
- result <- s_count_values(+ if (eff) {
|
| 80 | -51x | +234 | +65x |
- as.character(unique(df[[.var]])),+ if (multivar && !var_main) { # multivar treatment level
|
| 81 | -51x | +235 | +12x |
- id_satisfy_filters,+ var_lbl_arm <- formatters::var_labels(df)[[variables$arm]] |
| 82 | -51x | +236 | +12x |
- denom = denom,+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
|
| 83 | -51x | +|||
| 237 | +
- .N_col = .N_col,+ } else { # treatment effect
|
|||
| 84 | -51x | -
- .N_row = .N_row- |
- ||
| 85 | -+ | 238 | +53x |
- )+ vars_coxreg["var_nms"] <- variables$arm |
| 86 | -51x | +239 | +12x |
- result+ if (var_main) vars_coxreg["which_vars"] <- "var_main" |
| 87 | +240 |
- }+ } |
||
| 88 | +241 |
-
+ } else {
|
||
| 89 | -+ | |||
| 242 | +223x |
- #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun`+ if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
|
||
| 90 | -+ | |||
| 243 | +166x |
- #' in `count_patients_with_event()`.+ vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
|
||
| 91 | -+ | |||
| 244 | +57x |
- #'+ } else if (multivar) { # multivar covariate level
|
||
| 92 | -+ | |||
| 245 | +57x |
- #' @return+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
|
||
| 93 | -+ | |||
| 246 | +12x |
- #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()].+ if (var_main) model[cov, .stats] <- NA_real_ |
||
| 94 | +247 |
- #'+ } |
||
| 95 | -+ | |||
| 248 | +50x |
- #' @examples+ if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect |
||
| 96 | +249 |
- #' a_count_patients_with_event(+ } |
||
| 97 | -+ | |||
| 250 | +288x |
- #' tern_ex_adae,+ var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]] |
||
| 98 | -+ | |||
| 251 | +288x |
- #' .var = "SUBJID",+ var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
|
||
| 99 | -+ | |||
| 252 | +27x |
- #' filters = c("TRTEMFL" = "Y"),
+ paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels |
||
| 100 | -+ | |||
| 253 | +288x |
- #' .N_col = 100,+ } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) || |
||
| 101 | -+ | |||
| 254 | +288x |
- #' .N_row = 100+ (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
|
||
| 102 | -+ | |||
| 255 | +71x |
- #' )+ labelstr # other main effect labels |
||
| 103 | -+ | |||
| 256 | +288x |
- #'+ } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
|
||
| 104 | -+ | |||
| 257 | +12x |
- #' @export+ "All" # multivar numeric covariate |
||
| 105 | +258 |
- a_count_patients_with_event <- function(df,+ } else {
|
||
| 106 | -+ | |||
| 259 | +178x |
- labelstr = "",+ names(var_vals) |
||
| 107 | +260 |
- filters,+ } |
||
| 108 | -+ | |||
| 261 | +288x |
- denom = c("n", "N_col", "N_row"),
+ in_rows( |
||
| 109 | -+ | |||
| 262 | +288x |
- .N_col, # nolint+ .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods, |
||
| 110 | -+ | |||
| 263 | +288x |
- .N_row, # nolint+ .formats = stats::setNames(rep(.formats, length(var_names)), var_names), |
||
| 111 | -+ | |||
| 264 | +288x |
- .df_row,+ .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names) |
||
| 112 | +265 |
- .var = NULL,+ ) |
||
| 113 | +266 |
- .stats = NULL,+ } |
||
| 114 | +267 |
- .formats = NULL,+ |
||
| 115 | +268 |
- .labels = NULL,+ #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table |
||
| 116 | +269 |
- .indent_mods = NULL,+ #' layout. This function is a wrapper for several `rtables` layouting functions. This function |
||
| 117 | +270 |
- na_str = default_na_str()) {
+ #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()]. |
||
| 118 | -19x | +|||
| 271 | +
- x_stats <- s_count_patients_with_event(+ #' |
|||
| 119 | -19x | +|||
| 272 | +
- df = df, .var = .var, filters = filters, .N_col = .N_col, .N_row = .N_row, denom = denom+ #' @inheritParams fit_coxreg_univar |
|||
| 120 | +273 |
- )+ #' @param multivar (`flag`)\cr whether multivariate Cox regression should run (defaults to `FALSE`), otherwise |
||
| 121 | +274 |
-
+ #' univariate Cox regression will run. |
||
| 122 | -19x | +|||
| 275 | +
- if (is.null(unlist(x_stats))) {
+ #' @param common_var (`string`)\cr the name of a factor variable in the dataset which takes the same value |
|||
| 123 | -! | +|||
| 276 | +
- return(NULL)+ #' for all rows. This should be created during pre-processing if no such variable currently exists. |
|||
| 124 | +277 |
- }+ #' @param .section_div (`string` or `NA`)\cr string which should be repeated as a section divider between sections. |
||
| 125 | +278 |
-
+ #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between |
||
| 126 | +279 |
- # Fill in with formatting defaults if needed+ #' treatment and covariate sections and the second between different covariates. |
||
| 127 | -19x | +|||
| 280 | +
- .stats <- get_stats("count_patients_with_event", stats_in = .stats)
+ #' |
|||
| 128 | -19x | +|||
| 281 | +
- .formats <- get_formats_from_stats(.stats, .formats)+ #' @return |
|||
| 129 | -19x | +|||
| 282 | +
- .labels <- get_labels_from_stats(.stats, .labels)+ #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions, |
|||
| 130 | -19x | +|||
| 283 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table |
|||
| 131 | +284 |
-
+ #' containing the chosen statistics to the table layout. |
||
| 132 | -1x | +|||
| 285 | +
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ #' |
|||
| 133 | -19x | +|||
| 286 | +
- x_stats <- x_stats[.stats]+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`, |
|||
| 134 | +287 |
-
+ #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate |
||
| 135 | +288 |
- # Auto format handling+ #' Cox regression models, respectively. |
||
| 136 | -19x | +|||
| 289 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' |
|||
| 137 | +290 |
-
+ #' @examples |
||
| 138 | -19x | +|||
| 291 | +
- in_rows(+ #' # summarize_coxreg |
|||
| 139 | -19x | +|||
| 292 | +
- .list = x_stats,+ #' |
|||
| 140 | -19x | +|||
| 293 | +
- .formats = .formats,+ #' result_univar <- basic_table() %>% |
|||
| 141 | -19x | +|||
| 294 | +
- .names = names(.labels),+ #' summarize_coxreg(variables = u1_variables) %>% |
|||
| 142 | -19x | +|||
| 295 | +
- .labels = unlist(.labels),+ #' build_table(dta_bladder) |
|||
| 143 | -19x | +|||
| 296 | +
- .indent_mods = .indent_mods,+ #' result_univar |
|||
| 144 | -19x | +|||
| 297 | +
- .format_na_strs = na_str+ #' |
|||
| 145 | +298 |
- )+ #' result_univar_covs <- basic_table() %>% |
||
| 146 | +299 |
- }+ #' summarize_coxreg( |
||
| 147 | +300 |
-
+ #' variables = u2_variables, |
||
| 148 | +301 |
- #' @describeIn count_patients_with_event Layout-creating function which can take statistics function+ #' ) %>% |
||
| 149 | +302 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' build_table(dta_bladder) |
||
| 150 | +303 |
- #'+ #' result_univar_covs |
||
| 151 | +304 |
- #' @return+ #' |
||
| 152 | +305 |
- #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions,+ #' result_multivar <- basic_table() %>% |
||
| 153 | +306 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' summarize_coxreg( |
||
| 154 | +307 |
- #' the statistics from `s_count_patients_with_event()` to the table layout.+ #' variables = m1_variables, |
||
| 155 | +308 |
- #'+ #' multivar = TRUE, |
||
| 156 | +309 |
- #' @examples+ #' ) %>% |
||
| 157 | +310 |
- #' lyt <- basic_table() %>%+ #' build_table(dta_bladder) |
||
| 158 | +311 |
- #' split_cols_by("ARM") %>%
+ #' result_multivar |
||
| 159 | +312 |
- #' add_colcounts() %>%+ #' |
||
| 160 | +313 |
- #' count_values(+ #' result_multivar_covs <- basic_table() %>% |
||
| 161 | +314 |
- #' "STUDYID",+ #' summarize_coxreg( |
||
| 162 | +315 |
- #' values = "AB12345",+ #' variables = m2_variables, |
||
| 163 | +316 |
- #' .stats = "count",+ #' multivar = TRUE, |
||
| 164 | +317 |
- #' .labels = c(count = "Total AEs")+ #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
|
||
| 165 | +318 |
#' ) %>% |
||
| 166 | +319 |
- #' count_patients_with_event(+ #' build_table(dta_bladder) |
||
| 167 | +320 |
- #' "SUBJID",+ #' result_multivar_covs |
||
| 168 | +321 |
- #' filters = c("TRTEMFL" = "Y"),
+ #' |
||
| 169 | +322 |
- #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"),+ #' @export |
||
| 170 | +323 |
- #' table_names = "tbl_all"+ #' @order 2 |
||
| 171 | +324 |
- #' ) %>%+ summarize_coxreg <- function(lyt, |
||
| 172 | +325 |
- #' count_patients_with_event(+ variables, |
||
| 173 | +326 |
- #' "SUBJID",+ control = control_coxreg(), |
||
| 174 | +327 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ at = list(), |
||
| 175 | +328 |
- #' .labels = c(count_fraction = "Total number of patients with fatal AEs"),+ multivar = FALSE, |
||
| 176 | +329 |
- #' table_names = "tbl_fatal"+ common_var = "STUDYID", |
||
| 177 | +330 |
- #' ) %>%+ .stats = c("n", "hr", "ci", "pval", "pval_inter"),
|
||
| 178 | +331 |
- #' count_patients_with_event(+ .formats = c( |
||
| 179 | +332 |
- #' "SUBJID",+ n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)", |
||
| 180 | +333 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
+ pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)" |
||
| 181 | +334 |
- #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"),+ ), |
||
| 182 | +335 |
- #' .indent_mods = c(count_fraction = 2L),+ varlabels = NULL, |
||
| 183 | +336 |
- #' table_names = "tbl_rel_fatal"+ .indent_mods = NULL, |
||
| 184 | +337 |
- #' )+ na_str = "", |
||
| 185 | +338 |
- #'+ .section_div = NA_character_) {
|
||
| 186 | -+ | |||
| 339 | +16x |
- #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl)+ if (multivar && control$interaction) {
|
||
| 187 | -+ | |||
| 340 | +1x |
- #'+ warning(paste( |
||
| 188 | -+ | |||
| 341 | +1x |
- #' @export+ "Interactions are not available for multivariate cox regression using summarize_coxreg.", |
||
| 189 | -+ | |||
| 342 | +1x |
- #' @order 2+ "The model will be calculated without interaction effects." |
||
| 190 | +343 |
- count_patients_with_event <- function(lyt,+ )) |
||
| 191 | +344 |
- vars,+ } |
||
| 192 | -+ | |||
| 345 | +16x |
- filters,+ if (control$interaction && !"arm" %in% names(variables)) {
|
||
| 193 | -+ | |||
| 346 | +1x |
- riskdiff = FALSE,+ stop("To include interactions please specify 'arm' in variables.")
|
||
| 194 | +347 |
- na_str = default_na_str(),+ } |
||
| 195 | +348 |
- nested = TRUE,+ |
||
| 196 | -+ | |||
| 349 | +15x |
- ...,+ .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
|
||
| 197 | -+ | |||
| 350 | +6x |
- table_names = vars,+ intersect(c("hr", "ci", "pval"), .stats)
|
||
| 198 | -+ | |||
| 351 | +15x |
- .stats = "count_fraction",+ } else if (control$interaction) {
|
||
| 199 | -+ | |||
| 352 | +5x |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
|
||
| 200 | +353 |
- .labels = NULL,+ } else {
+ |
+ ||
| 354 | +4x | +
+ intersect(c("n", "hr", "ci", "pval"), .stats)
|
||
| 201 | +355 |
- .indent_mods = NULL) {
+ } |
||
| 202 | -7x | +356 | +15x |
- checkmate::assert_flag(riskdiff)+ stat_labels <- c( |
| 203 | -7x | +357 | +15x |
- extra_args <- list(+ n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"), |
| 204 | -7x | +358 | +15x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ pval = "p-value", pval_inter = "Interaction p-value" |
| 205 | +359 |
) |
||
| 206 | -7x | -
- s_args <- list(filters = filters, ...)- |
- ||
| 207 | -+ | 360 | +15x |
-
+ stat_labels <- stat_labels[names(stat_labels) %in% .stats] |
| 208 | -7x | +361 | +15x |
- if (isFALSE(riskdiff)) {
+ .formats <- .formats[names(.formats) %in% .stats] |
| 209 | -5x | +362 | +15x |
- extra_args <- c(extra_args, s_args)+ env <- new.env() # create caching environment |
| 210 | +363 |
- } else {
+
|
||
| 211 | -2x | +364 | +15x |
- extra_args <- c(+ lyt <- lyt %>% |
| 212 | -2x | +365 | +15x |
- extra_args,+ split_cols_by_multivar( |
| 213 | -2x | +366 | +15x |
- list(+ vars = rep(common_var, length(.stats)), |
| 214 | -2x | +367 | +15x |
- afun = list("s_count_patients_with_event" = a_count_patients_with_event),
+ varlabels = stat_labels, |
| 215 | -2x | +368 | +15x |
- s_args = s_args+ extra_args = list( |
| 216 | -+ | |||
| 369 | +15x |
- )+ .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)),+ |
+ ||
| 370 | +15x | +
+ cache_env = replicate(length(.stats), list(env)) |
||
| 217 | +371 |
- )+ ) |
||
| 218 | +372 |
- }+ ) |
||
| 219 | +373 | |||
| 220 | -7x | +374 | +15x |
- analyze(+ if ("arm" %in% names(variables)) { # treatment effect
|
| 221 | -7x | +375 | +13x |
- lyt = lyt,+ lyt <- lyt %>% |
| 222 | -7x | +376 | +13x |
- vars = vars,+ split_rows_by( |
| 223 | -7x | +377 | +13x |
- afun = ifelse(isFALSE(riskdiff), a_count_patients_with_event, afun_riskdiff),+ common_var, |
| 224 | -7x | +378 | +13x |
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ split_label = "Treatment:", |
| 225 | -7x | +379 | +13x |
- table_names = table_names,+ label_pos = "visible", |
| 226 | -7x | +380 | +13x |
- na_str = na_str,+ child_labels = "hidden", |
| 227 | -7x | +381 | +13x |
- nested = nested,+ section_div = head(.section_div, 1) |
| 228 | -7x | +|||
| 382 | +
- extra_args = extra_args+ ) |
|||
| 229 | -+ | |||
| 383 | +13x |
- )+ if (!multivar) {
|
||
| 230 | -+ | |||
| 384 | +9x |
- }+ lyt <- lyt %>% |
| 1 | -+ | ||
| 385 | +9x |
- #' Analyze a pairwise Cox-PH model+ analyze_colvars( |
|
| 2 | -+ | ||
| 386 | +9x |
- #'+ afun = a_coxreg, |
|
| 3 | -+ | ||
| 387 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ na_str = na_str, |
|
| 4 | -+ | ||
| 388 | +9x |
- #'+ extra_args = list( |
|
| 5 | -+ | ||
| 389 | +9x |
- #' The analyze function [coxph_pairwise()] creates a layout element to analyze a pairwise Cox-PH model.+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar, |
|
| 6 | -+ | ||
| 390 | +9x |
- #'+ labelstr = "" |
|
| 7 | +391 |
- #' This function can return statistics including p-value, hazard ratio (HR), and HR confidence intervals from both+ ) |
|
| 8 | +392 |
- #' stratified and unstratified Cox-PH models. The variable(s) to be analyzed is specified via the `vars` argument and+ ) |
|
| 9 | +393 |
- #' any stratification factors via the `strata` argument.+ } else { # treatment level effects
+ |
+ |
| 394 | +4x | +
+ lyt <- lyt %>%+ |
+ |
| 395 | +4x | +
+ summarize_row_groups(+ |
+ |
| 396 | +4x | +
+ cfun = a_coxreg,+ |
+ |
| 397 | +4x | +
+ na_str = na_str,+ |
+ |
| 398 | +4x | +
+ extra_args = list(+ |
+ |
| 399 | +4x | +
+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar |
|
| 10 | +400 | ++ |
+ )+ |
+
| 401 | ++ |
+ ) %>%+ |
+ |
| 402 | +4x | +
+ analyze_colvars(+ |
+ |
| 403 | +4x | +
+ afun = a_coxreg,+ |
+ |
| 404 | +4x | +
+ na_str = na_str,+ |
+ |
| 405 | +4x | +
+ extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "")+ |
+ |
| 406 | ++ |
+ )+ |
+ |
| 407 | ++ |
+ }+ |
+ |
| 408 | ++ |
+ }+ |
+ |
| 409 | ++ | + + | +|
| 410 | +15x | +
+ if ("covariates" %in% names(variables)) { # covariate main effects
+ |
+ |
| 411 | +15x | +
+ lyt <- lyt %>%+ |
+ |
| 412 | +15x | +
+ split_rows_by_multivar(+ |
+ |
| 413 | +15x | +
+ vars = variables$covariates,+ |
+ |
| 414 | +15x | +
+ varlabels = varlabels,+ |
+ |
| 415 | +15x | +
+ split_label = "Covariate:",+ |
+ |
| 416 | +15x | +
+ nested = FALSE,+ |
+ |
| 417 | +15x | +
+ child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ |
+ |
| 418 | +15x | +
+ section_div = tail(.section_div, 1)+ |
+ |
| 419 | ++ |
+ )+ |
+ |
| 420 | +15x | +
+ if (multivar || control$interaction || !"arm" %in% names(variables)) {
+ |
+ |
| 421 | +11x | +
+ lyt <- lyt %>%+ |
+ |
| 422 | +11x | +
+ summarize_row_groups(+ |
+ |
| 423 | +11x | +
+ cfun = a_coxreg,+ |
+ |
| 424 | +11x | +
+ na_str = na_str,+ |
+ |
| 425 | +11x | +
+ extra_args = list(+ |
+ |
| 426 | +11x | +
+ variables = variables, at = at, control = control, multivar = multivar,+ |
+ |
| 427 | +11x | +
+ var_main = if (multivar) multivar else control$interaction+ |
+ |
| 428 | ++ |
+ )+ |
+ |
| 429 | ++ |
+ )+ |
+ |
| 430 | ++ |
+ } else {
+ |
+ |
| 431 | +1x | +
+ if (!is.null(varlabels)) names(varlabels) <- variables$covariates+ |
+ |
| 432 | +4x | +
+ lyt <- lyt %>%+ |
+ |
| 433 | +4x | +
+ analyze_colvars(+ |
+ |
| 434 | +4x | +
+ afun = a_coxreg,+ |
+ |
| 435 | +4x | +
+ na_str = na_str,+ |
+ |
| 436 | +4x | +
+ extra_args = list(+ |
+ |
| 437 | +4x | +
+ variables = variables, at = at, control = control, multivar = multivar,+ |
+ |
| 438 | +4x | +
+ var_main = if (multivar) multivar else control$interaction,+ |
+ |
| 439 | +4x | +
+ labelstr = if (is.null(varlabels)) "" else varlabels+ |
+ |
| 440 | ++ |
+ )+ |
+ |
| 441 | ++ |
+ )+ |
+ |
| 442 | ++ |
+ }+ |
+ |
| 443 | ++ | + + | +|
| 444 | +2x | +
+ if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm+ |
+ |
| 445 | +15x | +
+ if (multivar || control$interaction) { # covariate level effects
+ |
+ |
| 446 | +11x | +
+ lyt <- lyt %>%+ |
+ |
| 447 | +11x | +
+ analyze_colvars(+ |
+ |
| 448 | +11x | +
+ afun = a_coxreg,+ |
+ |
| 449 | +11x | +
+ na_str = na_str,+ |
+ |
| 450 | +11x | +
+ extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""),+ |
+ |
| 451 | +11x | +
+ indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L+ |
+ |
| 452 | ++ |
+ )+ |
+ |
| 453 | ++ |
+ }+ |
+ |
| 454 | ++ |
+ }+ |
+ |
| 455 | ++ | + + | +|
| 456 | +15x | +
+ lyt+ |
+ |
| 457 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Multivariate logistic regression table+ |
+ |
| 2 | ++ |
+ #'+ |
+ |
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 4 |
#' |
||
| 5 | ++ |
+ #' 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 | ++ |
+ #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and+ |
+ |
| 8 | ++ |
+ #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate+ |
+ |
| 9 | ++ |
+ #' category or specified values and corresponding Wald confidence intervals as default but allow user+ |
+ |
| 10 | ++ |
+ #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis+ |
+ |
| 11 |
- #' @inheritParams argument_convention+ #' that covariate has no effect on response in model containing all specified covariates. |
||
| 12 |
- #' @inheritParams s_surv_time+ #' Allow option to include one two-way interaction and present similar output for |
||
| 13 |
- #' @param strata (`character` or `NULL`)\cr variable names indicating stratification factors.+ #' each interaction degree of freedom. |
||
| 14 |
- #' @param strat `r lifecycle::badge("deprecated")` Please use the `strata` argument instead.
+ #' |
||
| 15 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' @inheritParams argument_convention |
||
| 16 |
- #' [control_coxph()]. Some possible parameter options are:+ #' @param drop_and_remove_str (`string`)\cr string to be dropped and removed. |
||
| 17 |
- #' * `pval_method` (`string`)\cr p-value method for testing the null hypothesis that hazard ratio = 1. Default+ #' |
||
| 18 |
- #' method is `"log-rank"` which comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"`+ #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 19 |
- #' (from [survival::coxph()]).+ #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout. |
||
| 20 |
- #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`,+ #' |
||
| 21 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()].+ #' @note For the formula, the variable names need to be standard `data.frame` column names without |
||
| 22 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ #' special characters. |
||
| 23 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' |
||
| 24 |
- #'+ #' @examples |
||
| 25 |
- #' Options are: ``r shQuote(get_stats("coxph_pairwise"))``
+ #' library(dplyr) |
||
| 26 |
- #'+ #' library(broom) |
||
| 27 |
- #' @name survival_coxph_pairwise+ #' |
||
| 28 |
- #' @order 1+ #' adrs_f <- tern_ex_adrs %>% |
||
| 29 |
- NULL+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 30 |
-
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 31 |
- #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR, and p-value of a Cox-PH model.+ #' mutate( |
||
| 32 |
- #'+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 33 |
- #' @return+ #' RACE = factor(RACE), |
||
| 34 |
- #' * `s_coxph_pairwise()` returns the statistics:+ #' SEX = factor(SEX) |
||
| 35 |
- #' * `pvalue`: p-value to test the null hypothesis that hazard ratio = 1.+ #' ) |
||
| 36 |
- #' * `hr`: Hazard ratio.+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 37 |
- #' * `hr_ci`: Confidence interval for hazard ratio.+ #' mod1 <- fit_logistic( |
||
| 38 |
- #' * `n_tot`: Total number of observations.+ #' data = adrs_f, |
||
| 39 |
- #' * `n_tot_events`: Total number of events.+ #' variables = list( |
||
| 40 |
- #'+ #' response = "Response", |
||
| 41 |
- #' @keywords internal+ #' arm = "ARMCD", |
||
| 42 |
- s_coxph_pairwise <- function(df,+ #' covariates = c("AGE", "RACE")
|
||
| 43 |
- .ref_group,+ #' ) |
||
| 44 |
- .in_ref_col,+ #' ) |
||
| 45 |
- .var,+ #' mod2 <- fit_logistic( |
||
| 46 |
- is_event,+ #' data = adrs_f, |
||
| 47 |
- strata = NULL,+ #' variables = list( |
||
| 48 |
- strat = lifecycle::deprecated(),+ #' response = "Response", |
||
| 49 |
- control = control_coxph()) {
+ #' arm = "ARMCD", |
||
| 50 | -92x | +
- if (lifecycle::is_present(strat)) {
+ #' covariates = c("AGE", "RACE"),
|
|
| 51 | -! | +
- lifecycle::deprecate_warn("0.9.4", "s_coxph_pairwise(strat)", "s_coxph_pairwise(strata)")
+ #' interaction = "AGE" |
|
| 52 | -! | +
- strata <- strat+ #' ) |
|
| 53 |
- }+ #' ) |
||
| 54 |
-
+ #' |
||
| 55 | -92x | +
- checkmate::assert_string(.var)+ #' df <- tidy(mod1, conf_level = 0.99) |
|
| 56 | -92x | +
- checkmate::assert_numeric(df[[.var]])+ #' df2 <- tidy(mod2, conf_level = 0.99) |
|
| 57 | -92x | +
- checkmate::assert_logical(df[[is_event]])+ #' |
|
| 58 | -92x | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ #' # flagging empty strings with "_" |
|
| 59 | -92x | +
- pval_method <- control$pval_method+ #' df <- df_explicit_na(df, na_level = "_") |
|
| 60 | -92x | +
- ties <- control$ties+ #' df2 <- df_explicit_na(df2, na_level = "_") |
|
| 61 | -92x | +
- conf_level <- control$conf_level+ #' |
|
| 62 |
-
+ #' result1 <- basic_table() %>% |
||
| 63 | -92x | +
- if (.in_ref_col) {
+ #' summarize_logistic( |
|
| 64 | -! | +
- return(+ #' conf_level = 0.95, |
|
| 65 | -! | +
- list(+ #' drop_and_remove_str = "_" |
|
| 66 | -! | +
- pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
+ #' ) %>% |
|
| 67 | -! | +
- hr = formatters::with_label("", "Hazard Ratio"),
+ #' build_table(df = df) |
|
| 68 | -! | +
- hr_ci = formatters::with_label("", f_conf_level(conf_level)),
+ #' result1 |
|
| 69 | -! | +
- n_tot = formatters::with_label("", "Total n"),
+ #' |
|
| 70 | -! | +
- n_tot_events = formatters::with_label("", "Total events")
+ #' result2 <- basic_table() %>% |
|
| 71 |
- )+ #' summarize_logistic( |
||
| 72 |
- )+ #' conf_level = 0.95, |
||
| 73 |
- }+ #' drop_and_remove_str = "_" |
||
| 74 | -92x | +
- data <- rbind(.ref_group, df)+ #' ) %>% |
|
| 75 | -92x | +
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ #' build_table(df = df2) |
|
| 76 |
-
+ #' result2 |
||
| 77 | -92x | +
- df_cox <- data.frame(+ #' |
|
| 78 | -92x | +
- tte = data[[.var]],+ #' @export |
|
| 79 | -92x | +
- is_event = data[[is_event]],+ #' @order 1 |
|
| 80 | -92x | +
- arm = group+ summarize_logistic <- function(lyt, |
|
| 81 |
- )+ conf_level, |
||
| 82 | -92x | +
- if (is.null(strata)) {
+ drop_and_remove_str = "", |
|
| 83 | -83x | +
- formula_cox <- survival::Surv(tte, is_event) ~ arm+ .indent_mods = NULL) {
|
|
| 84 |
- } else {
+ # checks |
||
| 85 | -9x | +3x |
- formula_cox <- stats::as.formula(+ checkmate::assert_string(drop_and_remove_str) |
| 86 | -9x | +
- paste0(+ |
|
| 87 | -9x | +3x |
- "survival::Surv(tte, is_event) ~ arm + strata(",
+ sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
|
| 88 | -9x | +3x |
- paste(strata, collapse = ","),+ 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 |
- )+ split_fun <- drop_and_remove_levels(drop_and_remove_str) |
| 91 |
- )+ |
||
| 92 | -9x | +3x |
- df_cox <- cbind(df_cox, data[strata])+ 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 | -92x | +3x |
- cox_fit <- survival::coxph(+ lyt <- sum_logistic_variable_test(lyt) |
| 95 | -92x | +3x |
- formula = formula_cox,+ lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun) |
| 96 | -92x | +3x |
- data = df_cox,+ lyt <- sum_logistic_term_estimates(lyt) |
| 97 | -92x | +3x |
- ties = ties+ lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun) |
| 98 | -+ | 3x |
- )+ lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun) |
| 99 | -92x | +3x |
- sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)+ lyt <- sum_logistic_odds_ratios(lyt) |
| 100 | -92x | +3x |
- orginal_survdiff <- survival::survdiff(+ lyt |
| 101 | -92x | +
- formula_cox,+ } |
|
| 102 | -92x | +
- data = df_cox+ |
|
| 103 |
- )+ #' Fit for logistic regression |
||
| 104 | -92x | +
- log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ #' |
|
| 105 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 106 | -92x | +
- pval <- switch(pval_method,+ #' |
|
| 107 | -92x | +
- "wald" = sum_cox$waldtest["pvalue"],+ #' Fit a (conditional) logistic regression model. |
|
| 108 | -92x | +
- "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff()+ #' |
|
| 109 | -92x | +
- "likelihood" = sum_cox$logtest["pvalue"]+ #' @inheritParams argument_convention |
|
| 110 |
- )+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 111 | -92x | +
- list(+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
|
| 112 | -92x | +
- pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
+ #' This will be used when fitting the (conditional) logistic regression model on the left hand |
|
| 113 | -92x | +
- hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),+ #' side of the formula. |
|
| 114 | -92x | +
- hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),+ #' |
|
| 115 | -92x | +
- n_tot = formatters::with_label(sum_cox$n, "Total n"),+ #' @return A fitted logistic regression model. |
|
| 116 | -92x | +
- n_tot_events = formatters::with_label(sum_cox$nevent, "Total events")+ #' |
|
| 117 |
- )+ #' @section Model Specification: |
||
| 118 |
- }+ #' |
||
| 119 |
-
+ #' The `variables` list needs to include the following elements: |
||
| 120 |
- #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`.+ #' * `arm`: Treatment arm variable name. |
||
| 121 |
- #'+ #' * `response`: The response arm variable name. Usually this is a 0/1 variable. |
||
| 122 |
- #' @return+ #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names. |
||
| 123 |
- #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `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. |
||
| 125 |
- #' @keywords internal+ #' |
||
| 126 |
- a_coxph_pairwise <- make_afun(+ #' @examples |
||
| 127 |
- s_coxph_pairwise,+ #' library(dplyr) |
||
| 128 |
- .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L),+ #' |
||
| 129 |
- .formats = c(+ #' adrs_f <- tern_ex_adrs %>% |
||
| 130 |
- pvalue = "x.xxxx | (<0.0001)",+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 131 |
- hr = "xx.xx",+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 132 |
- hr_ci = "(xx.xx, xx.xx)",+ #' mutate( |
||
| 133 |
- n_tot = "xx.xx",+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 134 |
- n_tot_events = "xx.xx"+ #' RACE = factor(RACE), |
||
| 135 |
- )+ #' SEX = factor(SEX) |
||
| 136 |
- )+ #' ) |
||
| 137 |
-
+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 138 |
- #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments+ #' mod1 <- fit_logistic( |
||
| 139 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' data = adrs_f, |
||
| 140 |
- #'+ #' variables = list( |
||
| 141 |
- #' @return+ #' response = "Response", |
||
| 142 |
- #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions,+ #' arm = "ARMCD", |
||
| 143 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' covariates = c("AGE", "RACE")
|
||
| 144 |
- #' the statistics from `s_coxph_pairwise()` to the table layout.+ #' ) |
||
| 145 |
- #'+ #' ) |
||
| 146 |
- #' @examples+ #' mod2 <- fit_logistic( |
||
| 147 |
- #' library(dplyr)+ #' data = adrs_f, |
||
| 148 |
- #'+ #' variables = list( |
||
| 149 |
- #' adtte_f <- tern_ex_adtte %>%+ #' response = "Response", |
||
| 150 |
- #' filter(PARAMCD == "OS") %>%+ #' arm = "ARMCD", |
||
| 151 |
- #' mutate(is_event = CNSR == 0)+ #' covariates = c("AGE", "RACE"),
|
||
| 152 |
- #'+ #' interaction = "AGE" |
||
| 153 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' ) |
||
| 154 |
- #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B")+ #' ) |
||
| 156 |
- #' basic_table() %>%+ #' @export |
||
| 157 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ fit_logistic <- function(data, |
||
| 158 |
- #' add_colcounts() %>%+ variables = list( |
||
| 159 |
- #' coxph_pairwise(+ response = "Response", |
||
| 160 |
- #' vars = "AVAL",+ arm = "ARMCD", |
||
| 161 |
- #' is_event = "is_event",+ covariates = NULL, |
||
| 162 |
- #' var_labels = "Unstratified Analysis"+ interaction = NULL, |
||
| 163 |
- #' ) %>%+ strata = NULL |
||
| 164 |
- #' build_table(df = adtte_f)+ ), |
||
| 165 |
- #'+ response_definition = "response") {
|
||
| 166 | -+ | 75x |
- #' basic_table() %>%+ assert_df_with_variables(data, variables) |
| 167 | -+ | 75x |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
|
| 168 | -+ | 75x |
- #' add_colcounts() %>%+ checkmate::assert_string(response_definition) |
| 169 | -+ | 75x |
- #' coxph_pairwise(+ checkmate::assert_true(grepl("response", response_definition))
|
| 170 |
- #' vars = "AVAL",+ |
||
| 171 | -+ | 75x |
- #' is_event = "is_event",+ response_definition <- sub( |
| 172 | -+ | 75x |
- #' var_labels = "Stratified Analysis",+ pattern = "response", |
| 173 | -+ | 75x |
- #' strata = "SEX",+ replacement = variables$response, |
| 174 | -+ | 75x |
- #' control = control_coxph(pval_method = "wald")+ x = response_definition, |
| 175 | -+ | 75x |
- #' ) %>%+ fixed = TRUE |
| 176 |
- #' build_table(df = adtte_f)+ ) |
||
| 177 | -+ | 75x |
- #'+ form <- paste0(response_definition, " ~ ", variables$arm) |
| 178 | -+ | 75x |
- #' @export+ if (!is.null(variables$covariates)) {
|
| 179 | -+ | 29x |
- #' @order 2+ form <- paste0(form, " + ", paste(variables$covariates, collapse = " + ")) |
| 180 |
- coxph_pairwise <- function(lyt,+ } |
||
| 181 | -+ | 75x |
- vars,+ if (!is.null(variables$interaction)) {
|
| 182 | -+ | 18x |
- strata = NULL,+ checkmate::assert_string(variables$interaction) |
| 183 | -+ | 18x |
- control = control_coxph(),+ checkmate::assert_subset(variables$interaction, variables$covariates) |
| 184 | -+ | 18x |
- na_str = default_na_str(),+ form <- paste0(form, " + ", variables$arm, ":", variables$interaction) |
| 185 |
- nested = TRUE,+ } |
||
| 186 | -+ | 75x |
- ...,+ if (!is.null(variables$strata)) {
|
| 187 | -+ | 14x |
- var_labels = "CoxPH",+ strata_arg <- if (length(variables$strata) > 1) {
|
| 188 | -+ | 7x |
- show_labels = "visible",+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
| 189 |
- table_names = vars,+ } else {
|
||
| 190 | -+ | 7x |
- .stats = c("pvalue", "hr", "hr_ci"),
+ variables$strata |
| 191 |
- .formats = NULL,+ } |
||
| 192 | -+ | 14x |
- .labels = NULL,+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
| 193 |
- .indent_mods = NULL) {
+ } |
||
| 194 | -5x | +75x |
- extra_args <- list(strata = strata, control = control, ...)+ formula <- stats::as.formula(form) |
| 195 | -+ | 75x |
-
+ if (is.null(variables$strata)) {
|
| 196 | -5x | +61x |
- afun <- make_afun(+ stats::glm( |
| 197 | -5x | +61x |
- a_coxph_pairwise,+ formula = formula, |
| 198 | -5x | +61x |
- .stats = .stats,+ data = data, |
| 199 | -5x | +61x |
- .formats = .formats,+ family = stats::binomial("logit")
|
| 200 | -5x | +
- .labels = .labels,+ ) |
|
| 201 | -5x | +
- .indent_mods = .indent_mods+ } else {
|
|
| 202 | -+ | 14x |
- )+ clogit_with_tryCatch( |
| 203 | -5x | +14x |
- analyze(+ formula = formula, |
| 204 | -5x | +14x |
- lyt,+ data = data, |
| 205 | -5x | +14x |
- vars,+ x = TRUE |
| 206 | -5x | +
- var_labels = var_labels,+ ) |
|
| 207 | -5x | +
- show_labels = show_labels,+ } |
|
| 208 | -5x | +
- table_names = table_names,+ } |
|
| 209 | -5x | +
- afun = afun,+ |
|
| 210 | -5x | +
- na_str = na_str,+ #' Custom tidy method for binomial GLM results |
|
| 211 | -5x | +
- nested = nested,+ #' |
|
| 212 | -5x | +
- extra_args = extra_args+ #' @description `r lifecycle::badge("stable")`
|
|
| 213 |
- )+ #' |
||
| 214 |
- }+ #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object |
| 1 | +215 |
- #' Count occurrences+ #' with `binomial` family. |
||
| 2 | +216 |
#' |
||
| 3 | +217 |
- #' @description `r lifecycle::badge("stable")`
+ #' @inheritParams argument_convention |
||
| 4 | +218 |
- #'+ #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise the median is used. |
||
| 5 | +219 |
- #' The analyze function [count_occurrences()] creates a layout element to calculate occurrence counts for patients.+ #' @param x (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
||
| 6 | +220 |
#' |
||
| 7 | +221 |
- #' This function analyzes the variable(s) supplied to `vars` and returns a table of occurrence counts for+ #' @return A `data.frame` containing the tidied model. |
||
| 8 | +222 |
- #' each unique value (or level) of the variable(s). This variable (or variables) must be+ #' |
||
| 9 | +223 |
- #' non-numeric. The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`).+ #' @method tidy glm |
||
| 10 | +224 |
#' |
||
| 11 | +225 |
- #' If there are multiple occurrences of the same value recorded for a patient, the value is only counted once.+ #' @seealso [h_logistic_regression] for relevant helper functions. |
||
| 12 | +226 |
#' |
||
| 13 | +227 |
- #' The summarize function [summarize_occurrences()] performs the same function as [count_occurrences()] except it+ #' @examples |
||
| 14 | +228 |
- #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of+ #' library(dplyr) |
||
| 15 | +229 |
- #' the latest row split or the root of the table if no row splits have occurred.+ #' library(broom) |
||
| 16 | +230 |
#' |
||
| 17 | +231 |
- #' @inheritParams argument_convention+ #' adrs_f <- tern_ex_adrs %>% |
||
| 18 | +232 |
- #' @param drop (`flag`)\cr whether non-appearing occurrence levels should be dropped from the resulting table.+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 19 | +233 |
- #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically.+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 20 | +234 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' mutate( |
||
| 21 | +235 |
- #'+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 22 | +236 |
- #' Options are: ``r shQuote(get_stats("count_occurrences"))``
+ #' RACE = factor(RACE), |
||
| 23 | +237 |
- #'+ #' SEX = factor(SEX) |
||
| 24 | +238 |
- #' @note By default, occurrences which don't appear in a given row split are dropped from the table and+ #' ) |
||
| 25 | +239 |
- #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 26 | +240 |
- #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would+ #' mod1 <- fit_logistic( |
||
| 27 | +241 |
- #' like to show all occurrences.+ #' data = adrs_f, |
||
| 28 | +242 |
- #'+ #' variables = list( |
||
| 29 | +243 |
- #' @examples+ #' response = "Response", |
||
| 30 | +244 |
- #' library(dplyr)+ #' arm = "ARMCD", |
||
| 31 | +245 |
- #' df <- data.frame(+ #' covariates = c("AGE", "RACE")
|
||
| 32 | +246 |
- #' USUBJID = as.character(c(+ #' ) |
||
| 33 | +247 |
- #' 1, 1, 2, 4, 4, 4,+ #' ) |
||
| 34 | +248 |
- #' 6, 6, 6, 7, 7, 8+ #' mod2 <- fit_logistic( |
||
| 35 | +249 |
- #' )),+ #' data = adrs_f, |
||
| 36 | +250 |
- #' MHDECOD = c(+ #' variables = list( |
||
| 37 | +251 |
- #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",+ #' response = "Response", |
||
| 38 | +252 |
- #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"+ #' arm = "ARMCD", |
||
| 39 | +253 |
- #' ),+ #' covariates = c("AGE", "RACE"),
|
||
| 40 | +254 |
- #' ARM = rep(c("A", "B"), each = 6),
+ #' interaction = "AGE" |
||
| 41 | +255 |
- #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
+ #' ) |
||
| 42 | +256 |
#' ) |
||
| 43 | +257 |
- #' df_adsl <- df %>%+ #' |
||
| 44 | +258 |
- #' select(USUBJID, ARM) %>%+ #' df <- tidy(mod1, conf_level = 0.99) |
||
| 45 | +259 |
- #' unique()+ #' df2 <- tidy(mod2, conf_level = 0.99) |
||
| 46 | +260 |
#' |
||
| 47 | +261 |
- #' @name count_occurrences+ #' @export |
||
| 48 | +262 |
- #' @order 1+ tidy.glm <- function(x, # nolint |
||
| 49 | +263 |
- NULL+ conf_level = 0.95, |
||
| 50 | +264 |
-
+ at = NULL, |
||
| 51 | +265 |
- #' @describeIn count_occurrences Statistics function which counts number of patients that report an+ ...) {
|
||
| 52 | -+ | |||
| 266 | +5x |
- #' occurrence.+ checkmate::assert_class(x, "glm") |
||
| 53 | -+ | |||
| 267 | +5x |
- #'+ checkmate::assert_set_equal(x$family$family, "binomial") |
||
| 54 | +268 |
- #' @param denom (`string`)\cr choice of denominator for proportion. Options are:+ |
||
| 55 | -+ | |||
| 269 | +5x |
- #' * `N_col`: total number of patients in this column across rows.+ terms_name <- attr(stats::terms(x), "term.labels") |
||
| 56 | -+ | |||
| 270 | +5x |
- #' * `n`: number of patients with any occurrences.+ xs_class <- attr(x$terms, "dataClasses") |
||
| 57 | -+ | |||
| 271 | +5x |
- #' * `N_row`: total number of patients in this row across columns.+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
||
| 58 | -+ | |||
| 272 | +5x |
- #'+ df <- if (length(interaction) == 0) {
|
||
| 59 | -+ | |||
| 273 | +2x |
- #' @return+ h_logistic_simple_terms( |
||
| 60 | -+ | |||
| 274 | +2x |
- #' * `s_count_occurrences()` returns a list with:+ x = terms_name, |
||
| 61 | -+ | |||
| 275 | +2x |
- #' * `count`: list of counts with one element per occurrence.+ fit_glm = x,+ |
+ ||
| 276 | +2x | +
+ conf_level = conf_level |
||
| 62 | +277 |
- #' * `count_fraction`: list of counts and fractions with one element per occurrence.+ ) |
||
| 63 | +278 |
- #' * `fraction`: list of numerators and denominators with one element per occurrence.+ } else {
+ |
+ ||
| 279 | +3x | +
+ h_logistic_inter_terms(+ |
+ ||
| 280 | +3x | +
+ x = terms_name,+ |
+ ||
| 281 | +3x | +
+ fit_glm = x,+ |
+ ||
| 282 | +3x | +
+ conf_level = conf_level,+ |
+ ||
| 283 | +3x | +
+ at = at |
||
| 64 | +284 |
- #'+ ) |
||
| 65 | +285 |
- #' @examples+ }+ |
+ ||
| 286 | +5x | +
+ for (var in c("variable", "term", "interaction", "reference")) {
+ |
+ ||
| 287 | +20x | +
+ df[[var]] <- factor(df[[var]], levels = unique(df[[var]])) |
||
| 66 | +288 |
- #' # Count unique occurrences per subject.+ }+ |
+ ||
| 289 | +5x | +
+ df |
||
| 67 | +290 |
- #' s_count_occurrences(+ } |
||
| 68 | +291 |
- #' df,+ |
||
| 69 | +292 |
- #' .N_col = 4L,+ #' Logistic regression multivariate column layout function |
||
| 70 | +293 |
- #' .N_row = 4L,+ #' |
||
| 71 | +294 |
- #' .df_row = df,+ #' @description `r lifecycle::badge("stable")`
|
||
| 72 | +295 |
- #' .var = "MHDECOD",+ #' |
||
| 73 | +296 |
- #' id = "USUBJID"+ #' Layout-creating function which creates a multivariate column layout summarizing logistic |
||
| 74 | +297 |
- #' )+ #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()]. |
||
| 75 | +298 |
#' |
||
| 76 | +299 |
- #' @export+ #' @inheritParams argument_convention |
||
| 77 | +300 |
- s_count_occurrences <- function(df,+ #' |
||
| 78 | +301 |
- denom = c("N_col", "n", "N_row"),
+ #' @return A layout object suitable for passing to further layouting functions. Adding this |
||
| 79 | +302 |
- .N_col, # nolint+ #' function to an `rtable` layout will split the table into columns corresponding to |
||
| 80 | +303 |
- .N_row, # nolint+ #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`. |
||
| 81 | +304 |
- .df_row,+ #' |
||
| 82 | +305 |
- drop = TRUE,+ #' @export |
||
| 83 | +306 |
- .var = "MHDECOD",+ logistic_regression_cols <- function(lyt, |
||
| 84 | +307 |
- id = "USUBJID") {
+ conf_level = 0.95) {
|
||
| 85 | -126x | +308 | +4x |
- checkmate::assert_flag(drop)+ vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
|
| 86 | -126x | +309 | +4x |
- assert_df_with_variables(df, list(range = .var, id = id))+ var_labels <- c( |
| 87 | -126x | +310 | +4x |
- checkmate::assert_count(.N_col)+ df = "Degrees of Freedom", |
| 88 | -126x | +311 | +4x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ estimate = "Parameter Estimate", |
| 89 | -126x | +312 | +4x |
- checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
+ std_error = "Standard Error", |
| 90 | -+ | |||
| 313 | +4x |
-
+ odds_ratio = "Odds Ratio", |
||
| 91 | -126x | +314 | +4x |
- occurrences <- if (drop) {
+ ci = paste("Wald", f_conf_level(conf_level)),
|
| 92 | -+ | |||
| 315 | +4x |
- # Note that we don't try to preserve original level order here since a) that would required+ pvalue = "p-value" |
||
| 93 | +316 |
- # more time to look up in large original levels and b) that would fail for character input variable.+ ) |
||
| 94 | -115x | +317 | +4x |
- occurrence_levels <- sort(unique(.df_row[[.var]]))+ split_cols_by_multivar( |
| 95 | -115x | +318 | +4x |
- if (length(occurrence_levels) == 0) {
+ lyt = lyt, |
| 96 | -1x | +319 | +4x |
- stop(+ vars = vars, |
| 97 | -1x | +320 | +4x |
- "no empty `.df_row` input allowed when `drop = TRUE`,",+ varlabels = var_labels |
| 98 | -1x | +|||
| 321 | +
- " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls"+ ) |
|||
| 99 | +322 |
- )+ } |
||
| 100 | +323 |
- }+ |
||
| 101 | -114x | +|||
| 324 | +
- factor(df[[.var]], levels = occurrence_levels)+ #' Logistic regression summary table |
|||
| 102 | +325 |
- } else {
+ #' |
||
| 103 | -11x | +|||
| 326 | +
- df[[.var]]+ #' @description `r lifecycle::badge("stable")`
|
|||
| 104 | +327 |
- }+ #' |
||
| 105 | -125x | +|||
| 328 | +
- ids <- factor(df[[id]])+ #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize |
|||
| 106 | -125x | +|||
| 329 | +
- denom <- match.arg(denom) %>%+ #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()]. |
|||
| 107 | -125x | +|||
| 330 | +
- switch(+ #' |
|||
| 108 | -125x | +|||
| 331 | +
- n = nlevels(ids),+ #' @inheritParams argument_convention |
|||
| 109 | -125x | +|||
| 332 | +
- N_row = .N_row,+ #' @param flag_var (`string`)\cr variable name identifying which row should be used in this |
|||
| 110 | -125x | +|||
| 333 | +
- N_col = .N_col+ #' content function. |
|||
| 111 | +334 |
- )+ #' |
||
| 112 | -125x | +|||
| 335 | +
- has_occurrence_per_id <- table(occurrences, ids) > 0+ #' @return A content function. |
|||
| 113 | -125x | +|||
| 336 | +
- n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id))+ #' |
|||
| 114 | -125x | +|||
| 337 | +
- list(+ #' @export |
|||
| 115 | -125x | +|||
| 338 | +
- count = n_ids_per_occurrence,+ logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
|
|||
| 116 | -125x | +339 | +10x |
- count_fraction = lapply(+ checkmate::assert_string(flag_var) |
| 117 | -125x | +340 | +10x |
- n_ids_per_occurrence,+ function(lyt) {
|
| 118 | -125x | +341 | +10x |
- function(i, denom) {
+ cfun_list <- list( |
| 119 | -514x | -
- if (i == 0 && denom == 0) {
- |
- ||
| 120 | -! | +342 | +10x |
- c(0, 0)+ df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
|
| 121 | -+ | |||
| 343 | +10x |
- } else {
+ estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
||
| 122 | -514x | +344 | +10x |
- c(i, i / denom)+ std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
| 123 | -+ | |||
| 345 | +10x |
- }+ odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
|
||
| 124 | -+ | |||
| 346 | +10x |
- },+ ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
|
||
| 125 | -125x | +347 | +10x |
- denom = denom+ pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
|
| 126 | +348 |
- ),+ ) |
||
| 127 | -125x | +349 | +10x |
- fraction = lapply(+ summarize_row_groups( |
| 128 | -125x | +350 | +10x |
- n_ids_per_occurrence,+ lyt = lyt, |
| 129 | -125x | +351 | +10x |
- function(i, denom) c("num" = i, "denom" = denom),
+ cfun = cfun_list, |
| 130 | -125x | +352 | +10x |
- denom = denom+ na_str = na_str |
| 131 | +353 |
) |
||
| 132 | +354 |
- )+ } |
||
| 133 | +355 |
} |
| 134 | +1 |
-
+ #' Count the number of patients with particular flags |
||
| 135 | +2 |
- #' @describeIn count_occurrences Formatted analysis function which is used as `afun`+ #' |
||
| 136 | +3 |
- #' in `count_occurrences()`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 137 | +4 |
#' |
||
| 138 | +5 |
- #' @return+ #' The analyze function [count_patients_with_flags()] creates a layout element to calculate counts of patients for |
||
| 139 | +6 |
- #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()].+ #' which user-specified flags are present. |
||
| 140 | +7 |
#' |
||
| 141 | +8 |
- #' @examples+ #' This function analyzes primary analysis variable `var` which indicates unique subject identifiers. Flags |
||
| 142 | +9 |
- #' a_count_occurrences(+ #' variables to analyze are specified by the user via the `flag_variables` argument, and must either take value |
||
| 143 | +10 |
- #' df,+ #' `TRUE` (flag present) or `FALSE` (flag absent) for each record. |
||
| 144 | +11 |
- #' .N_col = 4L,+ #' |
||
| 145 | +12 |
- #' .df_row = df,+ #' If there are multiple records with the same flag present for a patient, only one occurrence is counted. |
||
| 146 | +13 |
- #' .var = "MHDECOD",+ #' |
||
| 147 | +14 |
- #' id = "USUBJID"+ #' @inheritParams argument_convention |
||
| 148 | +15 |
- #' )+ #' @param flag_variables (`character`)\cr a vector specifying the names of `logical` variables from analysis dataset |
||
| 149 | +16 | ++ |
+ #' used for counting the number of unique identifiers.+ |
+ |
| 17 | ++ |
+ #' @param flag_labels (`character`)\cr vector of labels to use for flag variables. If any labels are also specified via+ |
+ ||
| 18 | ++ |
+ #' the `.labels` parameter, the `.labels` values will take precedence and replace these labels.+ |
+ ||
| 19 | ++ |
+ #' @param .stats (`character`)\cr statistics to select for the table.+ |
+ ||
| 20 |
#' |
|||
| 150 | +21 |
- #' @export+ #' Options are: ``r shQuote(get_stats("count_patients_with_flags"))``
|
||
| 151 | +22 |
- a_count_occurrences <- function(df,+ #' |
||
| 152 | +23 |
- labelstr = "",+ #' @seealso [count_patients_with_event] |
||
| 153 | +24 |
- id = "USUBJID",+ #' |
||
| 154 | +25 |
- denom = c("N_col", "n", "N_row"),
+ #' @name count_patients_with_flags |
||
| 155 | +26 |
- drop = TRUE,+ #' @order 1 |
||
| 156 | +27 |
- .N_col, # nolint+ NULL |
||
| 157 | +28 |
- .N_row, # nolint+ |
||
| 158 | +29 |
- .var = NULL,+ #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which |
||
| 159 | +30 |
- .df_row = NULL,+ #' a particular flag variable is `TRUE`. |
||
| 160 | +31 |
- .stats = NULL,+ #' |
||
| 161 | +32 |
- .formats = NULL,+ #' @inheritParams analyze_variables |
||
| 162 | +33 |
- .labels = NULL,+ #' @param .var (`string`)\cr name of the column that contains the unique identifier. |
||
| 163 | +34 |
- .indent_mods = NULL,+ #' |
||
| 164 | +35 |
- na_str = default_na_str()) {
+ #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not |
||
| 165 | -85x | +|||
| 36 | +
- denom <- match.arg(denom)+ #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to |
|||
| 166 | -85x | +|||
| 37 | +
- x_stats <- s_count_occurrences(+ #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is |
|||
| 167 | -85x | +|||
| 38 | +
- df = df, denom = denom, .N_col = .N_col, .N_row = .N_row, .df_row = .df_row, drop = drop, .var = .var, id = id+ #' the label to use for this variable. |
|||
| 168 | +39 |
- )+ #' |
||
| 169 | -85x | +|||
| 40 | +
- if (is.null(unlist(x_stats))) {
+ #' @return |
|||
| 170 | -3x | +|||
| 41 | +
- return(NULL)+ #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular |
|||
| 171 | +42 |
- }+ #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag. |
||
| 172 | -82x | +|||
| 43 | +
- x_lvls <- names(x_stats[[1]])+ #' |
|||
| 173 | +44 |
-
+ #' @examples |
||
| 174 | +45 |
- # Fill in with formatting defaults if needed+ #' # `s_count_patients_with_flags()` |
||
| 175 | -82x | +|||
| 46 | +
- .stats <- get_stats("count_occurrences", stats_in = .stats)
+ #' |
|||
| 176 | -82x | +|||
| 47 | +
- .formats <- get_formats_from_stats(.stats, .formats)+ #' s_count_patients_with_flags( |
|||
| 177 | -82x | +|||
| 48 | +
- .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls)+ #' adae, |
|||
| 178 | -82x | +|||
| 49 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls)+ #' "SUBJID", |
|||
| 179 | +50 |
-
+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
||
| 180 | -81x | +|||
| 51 | +
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ #' denom = "N_col", |
|||
| 181 | -82x | +|||
| 52 | +
- x_stats <- x_stats[.stats]+ #' .N_col = 1000 |
|||
| 182 | +53 |
-
+ #' ) |
||
| 183 | +54 |
- # Ungroup statistics with values for each level of x+ #' |
||
| 184 | -82x | +|||
| 55 | +
- x_ungrp <- ungroup_stats(x_stats, .formats, list(), list())+ #' @export |
|||
| 185 | -82x | +|||
| 56 | +
- x_stats <- x_ungrp[["x"]]+ s_count_patients_with_flags <- function(df, |
|||
| 186 | -82x | +|||
| 57 | +
- .formats <- x_ungrp[[".formats"]]+ .var, |
|||
| 187 | +58 |
-
+ flag_variables, |
||
| 188 | +59 |
- # Auto format handling+ flag_labels = NULL, |
||
| 189 | -82x | +|||
| 60 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ .N_col, # nolint |
|||
| 190 | +61 |
-
+ .N_row, # nolint |
||
| 191 | -82x | +|||
| 62 | +
- in_rows(+ denom = c("n", "N_col", "N_row")) {
|
|||
| 192 | -82x | +63 | +41x |
- .list = x_stats,+ checkmate::assert_character(flag_variables) |
| 193 | -82x | +64 | +41x |
- .formats = .formats,+ if (!is.null(flag_labels)) {
|
| 194 | -82x | +65 | +6x |
- .names = .labels,+ checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE) |
| 195 | -82x | +66 | +6x |
- .labels = .labels,+ flag_names <- flag_labels+ |
+
| 67 | ++ |
+ } else {
|
||
| 196 | -82x | +68 | +35x |
- .indent_mods = .indent_mods,+ if (is.null(names(flag_variables))) {
|
| 197 | -82x | +69 | +20x |
- .format_na_strs = na_str+ flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE) |
| 198 | +70 |
- )+ } else {
|
||
| 199 | -+ | |||
| 71 | +15x |
- }+ flag_names <- unname(flag_variables)+ |
+ ||
| 72 | +15x | +
+ flag_variables <- names(flag_variables) |
||
| 200 | +73 |
-
+ } |
||
| 201 | +74 |
- #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments+ } |
||
| 202 | +75 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ + |
+ ||
| 76 | +41x | +
+ checkmate::assert_subset(flag_variables, colnames(df))+ |
+ ||
| 77 | +41x | +
+ temp <- sapply(flag_variables, function(x) {
+ |
+ ||
| 78 | +123x | +
+ tmp <- Map(function(y) which(df[[y]]), x)+ |
+ ||
| 79 | +123x | +
+ position_satisfy_flags <- Reduce(intersect, tmp)+ |
+ ||
| 80 | +123x | +
+ id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))+ |
+ ||
| 81 | +123x | +
+ s_count_values(+ |
+ ||
| 82 | +123x | +
+ as.character(unique(df[[.var]])),+ |
+ ||
| 83 | +123x | +
+ id_satisfy_flags,+ |
+ ||
| 84 | +123x | +
+ denom = denom,+ |
+ ||
| 85 | +123x | +
+ .N_col = .N_col,+ |
+ ||
| 86 | +123x | +
+ .N_row = .N_row |
||
| 203 | +87 |
- #'+ ) |
||
| 204 | +88 |
- #' @return+ })+ |
+ ||
| 89 | +41x | +
+ colnames(temp) <- flag_names+ |
+ ||
| 90 | +41x | +
+ temp <- data.frame(t(temp))+ |
+ ||
| 91 | +41x | +
+ result <- temp %>% as.list()+ |
+ ||
| 92 | +41x | +
+ if (length(flag_variables) == 1) {
+ |
+ ||
| 93 | +1x | +
+ for (i in 1:3) names(result[[i]]) <- flag_names[1] |
||
| 205 | +94 |
- #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions,+ }+ |
+ ||
| 95 | +41x | +
+ result |
||
| 206 | +96 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ } |
||
| 207 | +97 |
- #' the statistics from `s_count_occurrences()` to the table layout.+ |
||
| 208 | +98 |
- #'+ #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun` |
||
| 209 | +99 |
- #' @examples+ #' in `count_patients_with_flags()`. |
||
| 210 | +100 |
- #' # Create table layout+ #' |
||
| 211 | +101 |
- #' lyt <- basic_table() %>%+ #' @return |
||
| 212 | +102 |
- #' split_cols_by("ARM") %>%
+ #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 213 | +103 |
- #' add_colcounts() %>%+ #' |
||
| 214 | +104 |
- #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
+ #' @examples |
||
| 215 | +105 |
- #'+ #' a_count_patients_with_flags( |
||
| 216 | +106 |
- #' # Apply table layout to data and produce `rtable` object+ #' adae, |
||
| 217 | +107 |
- #' tbl <- lyt %>%+ #' .N_col = 10L, |
||
| 218 | +108 |
- #' build_table(df, alt_counts_df = df_adsl) %>%+ #' .N_row = 10L, |
||
| 219 | +109 |
- #' prune_table()+ #' .var = "USUBJID", |
||
| 220 | +110 |
- #'+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
|
||
| 221 | +111 |
- #' tbl+ #' ) |
||
| 222 | +112 |
#' |
||
| 223 | +113 |
#' @export |
||
| 224 | +114 |
- #' @order 2+ a_count_patients_with_flags <- function(df, |
||
| 225 | +115 |
- count_occurrences <- function(lyt,+ labelstr = "", |
||
| 226 | +116 |
- vars,+ flag_variables, |
||
| 227 | +117 |
- id = "USUBJID",+ flag_labels = NULL, |
||
| 228 | +118 |
- drop = TRUE,+ denom = c("n", "N_col", "N_row"),
|
||
| 229 | +119 |
- var_labels = vars,+ .N_col, # nolint |
||
| 230 | +120 |
- show_labels = "hidden",+ .N_row, # nolint |
||
| 231 | +121 |
- riskdiff = FALSE,+ .df_row, |
||
| 232 | +122 |
- na_str = default_na_str(),+ .var = NULL, |
||
| 233 | +123 |
- nested = TRUE,+ .stats = NULL, |
||
| 234 | +124 |
- ...,+ .formats = NULL, |
||
| 235 | +125 |
- table_names = vars,+ .labels = NULL, |
||
| 236 | +126 |
- .stats = "count_fraction_fixed_dp",+ .indent_mods = NULL, |
||
| 237 | +127 |
- .formats = NULL,+ na_str = default_na_str()) {
|
||
| 238 | -+ | |||
| 128 | +31x |
- .labels = NULL,+ x_stats <- s_count_patients_with_flags( |
||
| 239 | -+ | |||
| 129 | +31x |
- .indent_mods = NULL) {
+ df = df, .var = .var, flag_variables = flag_variables, flag_labels = flag_labels, |
||
| 240 | -9x | +130 | +31x |
- checkmate::assert_flag(riskdiff)+ .N_col = .N_col, .N_row = .N_row, denom = denom |
| 241 | +131 | ++ |
+ )+ |
+ |
| 132 | ||||
| 242 | -9x | +133 | +31x |
- extra_args <- list(+ if (is.null(unlist(x_stats))) {
|
| 243 | -9x | +|||
| 134 | +! |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ return(NULL) |
||
| 244 | +135 |
- )+ } |
||
| 245 | -9x | +136 | +31x |
- s_args <- list(id = id, drop = drop, ...)+ x_lvls <- names(x_stats[[1]]) |
| 246 | +137 | |||
| 138 | ++ |
+ # Fill in with formatting defaults if needed+ |
+ ||
| 247 | -9x | +139 | +31x |
- if (isFALSE(riskdiff)) {
+ .stats <- get_stats("count_patients_with_flags", stats_in = .stats)
|
| 248 | -6x | +140 | +31x |
- extra_args <- c(extra_args, s_args)+ .formats <- get_formats_from_stats(.stats, .formats) |
| 249 | +141 |
- } else {
+
+ |
+ ||
| 142 | ++ |
+ # label formatting |
||
| 250 | -3x | +143 | +31x |
- extra_args <- c(+ x_nms <- paste(rep(.stats, each = length(flag_variables)), flag_variables, sep = ".") |
| 251 | -3x | +144 | +31x |
- extra_args,+ new_lbls <- if (!is.null(.labels)) .labels[names(.labels) %in% x_nms] else NULL |
| 252 | -3x | +145 | +31x |
- list(+ .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls) %>% setNames(x_nms) |
| 253 | -3x | +146 | +31x |
- afun = list("s_count_occurrences" = a_count_occurrences),
+ if (!is.null(new_lbls)) {
|
| 254 | -3x | +147 | +1x |
- s_args = s_args+ which_lbls <- which(names(new_lbls) %in% names(.labels)) |
| 255 | -+ | |||
| 148 | +1x |
- )+ .labels[which_lbls] <- new_lbls |
||
| 256 | +149 |
- )+ } |
||
| 257 | +150 |
- }+ |
||
| 258 | +151 |
-
+ # indent mod formatting |
||
| 259 | -9x | +152 | +31x |
- analyze(+ indent_stat_def <- if (any(.stats %in% names(.indent_mods))) {
|
| 260 | -9x | +153 | +1x |
- lyt = lyt,+ .indent_mods[.stats[.stats %in% names(.indent_mods)]] |
| 261 | -9x | +|||
| 154 | +
- vars = vars,+ } else {
|
|||
| 262 | -9x | +155 | +30x |
- afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ NULL+ |
+
| 156 | ++ |
+ } |
||
| 263 | -9x | +157 | +31x |
- var_labels = var_labels,+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = flag_variables) |
| 264 | -9x | +158 | +31x |
- show_labels = show_labels,+ if (!is.null(names(.indent_mods))) {
|
| 265 | -9x | +159 | +29x |
- table_names = table_names,+ .indent_mods <- sapply(names(.indent_mods), function(x) {
|
| 266 | -9x | +160 | +114x |
- na_str = na_str,+ if (.indent_mods[x] == 0 && !is.null(length(indent_stat_def))) {
|
| 267 | -9x | +161 | +112x |
- nested = nested,+ idx <- which(names(indent_stat_def) == gsub("\\..*", "", x))
|
| 268 | -9x | +162 | +2x |
- extra_args = extra_args+ if (length(idx) > 0) .indent_mods[[x]] <- indent_stat_def[[idx]] |
| 269 | +163 |
- )+ } |
||
| 270 | -+ | |||
| 164 | +114x |
- }+ .indent_mods[x] |
||
| 271 | +165 |
-
+ }) |
||
| 272 | +166 |
- #' @describeIn count_occurrences Layout-creating function which can take content function arguments+ } |
||
| 273 | +167 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ |
||
| 274 | -+ | |||
| 168 | +1x |
- #'+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
||
| 275 | -+ | |||
| 169 | +31x |
- #' @return+ x_stats <- x_stats[.stats] |
||
| 276 | +170 |
- #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions,+ |
||
| 277 | +171 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ # Ungroup statistics with values for each level of x |
||
| 278 | -+ | |||
| 172 | +31x |
- #' containing the statistics from `s_count_occurrences()` to the table layout.+ x_ungrp <- ungroup_stats(x_stats, .formats, .labels, list()) |
||
| 279 | -+ | |||
| 173 | +31x |
- #'+ x_stats <- x_ungrp[["x"]] %>% setNames(x_nms) |
||
| 280 | -+ | |||
| 174 | +31x |
- #' @examples+ .formats <- x_ungrp[[".formats"]] %>% setNames(x_nms) |
||
| 281 | +175 |
- #' # Layout creating function with custom format.+ |
||
| 282 | +176 |
- #' basic_table() %>%+ # Auto format handling |
||
| 283 | -+ | |||
| 177 | +31x |
- #' add_colcounts() %>%+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 284 | +178 |
- #' split_rows_by("SEX", child_labels = "visible") %>%
+
+ |
+ ||
| 179 | +31x | +
+ in_rows(+ |
+ ||
| 180 | +31x | +
+ .list = x_stats,+ |
+ ||
| 181 | +31x | +
+ .formats = .formats,+ |
+ ||
| 182 | +31x | +
+ .names = names(.labels),+ |
+ ||
| 183 | +31x | +
+ .labels = unlist(.labels),+ |
+ ||
| 184 | +31x | +
+ .indent_mods = .indent_mods,+ |
+ ||
| 185 | +31x | +
+ .format_na_strs = na_str |
||
| 285 | +186 |
- #' summarize_occurrences(+ ) |
||
| 286 | +187 |
- #' var = "MHDECOD",+ } |
||
| 287 | +188 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+
|
||
| 288 | +189 |
- #' ) %>%+ #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function |
||
| 289 | +190 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 290 | +191 |
#' |
||
| 291 | +192 |
- #' @export+ #' @return |
||
| 292 | +193 |
- #' @order 3+ #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions, |
||
| 293 | +194 |
- summarize_occurrences <- function(lyt,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 294 | +195 |
- var,+ #' the statistics from `s_count_patients_with_flags()` to the table layout. |
||
| 295 | +196 |
- id = "USUBJID",+ #' |
||
| 296 | +197 |
- drop = TRUE,+ #' @examples |
||
| 297 | +198 |
- riskdiff = FALSE,+ #' # Add labelled flag variables to analysis dataset. |
||
| 298 | +199 |
- na_str = default_na_str(),+ #' adae <- tern_ex_adae %>% |
||
| 299 | +200 |
- ...,+ #' dplyr::mutate( |
||
| 300 | +201 |
- .stats = "count_fraction_fixed_dp",+ #' fl1 = TRUE %>% with_label("Total AEs"),
|
||
| 301 | +202 |
- .formats = NULL,+ #' fl2 = (TRTEMFL == "Y") %>% |
||
| 302 | +203 |
- .indent_mods = NULL,+ #' with_label("Total number of patients with at least one adverse event"),
|
||
| 303 | +204 |
- .labels = NULL) {
+ #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>% |
||
| 304 | -5x | +|||
| 205 | +
- checkmate::assert_flag(riskdiff)+ #' with_label("Total number of patients with fatal AEs"),
|
|||
| 305 | +206 |
-
+ #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>%+ |
+ ||
| 207 | ++ |
+ #' with_label("Total number of patients with related fatal AEs")
+ |
+ ||
| 208 | ++ |
+ #' )+ |
+ ||
| 209 | ++ |
+ #'+ |
+ ||
| 210 | ++ |
+ #' lyt <- basic_table() %>%+ |
+ ||
| 211 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+ ||
| 212 | ++ |
+ #' add_colcounts() %>%+ |
+ ||
| 213 | ++ |
+ #' count_patients_with_flags(+ |
+ ||
| 214 | ++ |
+ #' "SUBJID",+ |
+ ||
| 215 | ++ |
+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ |
+ ||
| 216 | ++ |
+ #' denom = "N_col"+ |
+ ||
| 217 | ++ |
+ #' )+ |
+ ||
| 218 | ++ |
+ #'+ |
+ ||
| 219 | ++ |
+ #' build_table(lyt, adae, alt_counts_df = tern_ex_adsl)+ |
+ ||
| 220 | ++ |
+ #'+ |
+ ||
| 221 | ++ |
+ #' @export+ |
+ ||
| 222 | ++ |
+ #' @order 2+ |
+ ||
| 223 | ++ |
+ count_patients_with_flags <- function(lyt,+ |
+ ||
| 224 | ++ |
+ var,+ |
+ ||
| 225 | ++ |
+ flag_variables,+ |
+ ||
| 226 | ++ |
+ flag_labels = NULL,+ |
+ ||
| 227 | ++ |
+ var_labels = var,+ |
+ ||
| 228 | ++ |
+ show_labels = "hidden",+ |
+ ||
| 229 | ++ |
+ riskdiff = FALSE,+ |
+ ||
| 230 | ++ |
+ na_str = default_na_str(),+ |
+ ||
| 231 | ++ |
+ nested = TRUE,+ |
+ ||
| 232 | ++ |
+ ...,+ |
+ ||
| 233 | ++ |
+ table_names = paste0("tbl_flags_", var),
+ |
+ ||
| 234 | ++ |
+ .stats = "count_fraction",+ |
+ ||
| 235 | ++ |
+ .formats = list(count_fraction = format_count_fraction_fixed_dp),+ |
+ ||
| 236 | ++ |
+ .indent_mods = NULL,+ |
+ ||
| 237 | ++ |
+ .labels = NULL) {
|
||
| 306 | -5x | +238 | +11x | +
+ checkmate::assert_flag(riskdiff)+ |
+
| 239 | +11x |
extra_args <- list( |
||
| 307 | -5x | +240 | +11x |
.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 308 | +241 |
) |
||
| 309 | -5x | +242 | +11x |
- s_args <- list(id = id, drop = drop, ...)+ s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...) |
| 310 | +243 | |||
| 311 | -5x | +244 | +11x |
if (isFALSE(riskdiff)) {
|
| 312 | -1x | +245 | +9x |
extra_args <- c(extra_args, s_args) |
| 313 | +246 |
} else {
|
||
| 314 | -4x | +247 | +2x |
extra_args <- c( |
| 315 | -4x | +248 | +2x |
extra_args, |
| 316 | -4x | +249 | +2x |
list( |
| 317 | -4x | +250 | +2x |
- afun = list("s_count_occurrences" = a_count_occurrences),
+ afun = list("s_count_patients_with_flags" = a_count_patients_with_flags),
|
| 318 | -4x | +251 | +2x |
s_args = s_args |
| 319 | +252 |
) |
||
| 320 | +253 |
) |
||
| 321 | +254 |
} |
||
| 322 | +255 | |||
| 323 | -5x | +256 | +11x |
- summarize_row_groups(+ analyze( |
| 324 | -5x | +257 | +11x |
lyt = lyt, |
| 325 | -5x | +258 | +11x |
- var = var,+ vars = var, |
| 326 | -5x | +259 | +11x |
- cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ afun = ifelse(isFALSE(riskdiff), a_count_patients_with_flags, afun_riskdiff), |
| 327 | -5x | +260 | +11x | +
+ var_labels = var_labels,+ |
+
| 261 | +11x | +
+ show_labels = show_labels,+ |
+ ||
| 262 | +11x | +
+ table_names = table_names,+ |
+ ||
| 263 | +11x |
na_str = na_str, |
||
| 328 | -5x | +264 | +11x | +
+ nested = nested,+ |
+
| 265 | +11x |
extra_args = extra_args |
||
| 329 | +266 |
) |
||
| 330 | +267 |
}@@ -118067,14 +116435,14 @@ tern coverage - 95.65% |
| 1 |
- #' Cumulative counts of numeric variable by thresholds+ #' Get default statistical methods and their associated formats, labels, and indent modifiers |
||
| 5 |
- #' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a+ #' Utility functions to get valid statistic methods for different method groups |
||
| 6 |
- #' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified+ #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers |
||
| 7 |
- #' threshold values.+ #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be |
||
| 8 |
- #'+ #' seen in [analyze_vars()]. See notes to understand why this is experimental. |
||
| 9 |
- #' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds`+ #' |
||
| 10 |
- #' argument as a numeric vector. Whether counts should include the threshold values, and whether to count+ #' @param stats (`character`)\cr statistical methods to get defaults for. |
||
| 11 |
- #' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail`+ #' |
||
| 12 |
- #' parameters, respectively.+ #' @details |
||
| 13 |
- #'+ #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`. |
||
| 14 |
- #' @inheritParams h_count_cumulative+ #' |
||
| 15 |
- #' @inheritParams argument_convention+ #' @note |
||
| 16 |
- #' @param thresholds (`numeric`)\cr vector of cutoff values for the counts.+ #' These defaults are experimental because we use the names of functions to retrieve the default |
||
| 17 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' statistics. This should be generalized in groups of methods according to more reasonable groupings. |
||
| 19 |
- #' Options are: ``r shQuote(get_stats("count_cumulative"))``
+ #' @name default_stats_formats_labels |
||
| 20 |
- #'+ NULL |
||
| 21 |
- #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()].+ |
||
| 22 |
- #'+ #' @describeIn default_stats_formats_labels Get statistics available for a given method |
||
| 23 |
- #' @name count_cumulative+ #' group (analyze function). To check available defaults see `tern::tern_default_stats` list. |
||
| 24 |
- #' @order 1+ #' |
||
| 25 |
- NULL+ #' @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 |
||
| 27 |
- #' Helper function for `s_count_cumulative()`+ #' method group. |
||
| 28 |
- #'+ #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group. |
||
| 29 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains |
||
| 30 |
- #'+ #' `"analyze_vars_counts"`) be added to the statistical methods? |
||
| 31 |
- #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.+ #' |
||
| 32 |
- #'+ #' @return |
||
| 33 |
- #' @inheritParams argument_convention+ #' * `get_stats()` returns a `character` vector of statistical methods. |
||
| 34 |
- #' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`.+ #' |
||
| 35 |
- #' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`.+ #' @examples |
||
| 36 |
- #' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in+ #' # analyze_vars is numeric |
||
| 37 |
- #' count, default is `TRUE`.+ #' num_stats <- get_stats("analyze_vars_numeric") # also the default
|
||
| 39 |
- #' @return A named vector with items:+ #' # Other type |
||
| 40 |
- #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold+ #' cnt_stats <- get_stats("analyze_vars_counts")
|
||
| 41 |
- #' of user specification.+ #' |
||
| 42 |
- #' * `fraction`: the fraction of the count.+ #' # Weirdly taking the pval from count_occurrences |
||
| 43 |
- #'+ #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
|
||
| 44 |
- #' @seealso [count_cumulative]+ #' |
||
| 45 |
- #'+ #' # All count_occurrences |
||
| 46 |
- #' @examples+ #' all_cnt_occ <- get_stats("count_occurrences")
|
||
| 47 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' |
||
| 48 |
- #' x <- c(sample(1:10, 10), NA)+ #' # Multiple |
||
| 49 |
- #' .N_col <- length(x)+ #' get_stats(c("count_occurrences", "analyze_vars_counts"))
|
||
| 51 |
- #' h_count_cumulative(x, 5, .N_col = .N_col)+ #' @export |
||
| 52 |
- #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)+ get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
|
||
| 53 | -+ | 614x |
- #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)+ checkmate::assert_character(method_groups) |
| 54 | -+ | 614x |
- #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)+ checkmate::assert_character(stats_in, null.ok = TRUE) |
| 55 | -+ | 614x |
- #'+ checkmate::assert_flag(add_pval) |
| 56 |
- #' @export+ |
||
| 57 |
- h_count_cumulative <- function(x,+ # Default is still numeric |
||
| 58 | -+ | 614x |
- threshold,+ if (any(method_groups == "analyze_vars")) {
|
| 59 | -+ | 3x |
- lower_tail = TRUE,+ method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric" |
| 60 |
- include_eq = TRUE,+ } |
||
| 61 |
- na.rm = TRUE, # nolint+ |
||
| 62 | -+ | 614x |
- .N_col) { # nolint
+ type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
|
| 63 | -36x | +
- checkmate::assert_numeric(x)+ |
|
| 64 | -36x | +
- checkmate::assert_numeric(threshold)+ # Defaults for loop |
|
| 65 | -36x | +614x |
- checkmate::assert_numeric(.N_col)+ out <- NULL |
| 66 | -36x | +
- checkmate::assert_flag(lower_tail)+ |
|
| 67 | -36x | +
- checkmate::assert_flag(include_eq)+ # Loop for multiple method groups |
|
| 68 | -36x | +614x |
- checkmate::assert_flag(na.rm)+ for (mgi in method_groups) {
|
| 69 | -+ | 641x |
-
+ out_tmp <- if (mgi %in% names(tern_default_stats)) {
|
| 70 | -36x | +640x |
- is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))+ tern_default_stats[[mgi]] |
| 71 | -36x | +
- count <- if (lower_tail && include_eq) {
+ } else {
|
|
| 72 | -7x | +1x |
- length(x[is_keep & x <= threshold])+ stop("The selected method group (", mgi, ") has no default statistical method.")
|
| 73 | -36x | +
- } else if (lower_tail && !include_eq) {
+ } |
|
| 74 | -! | +640x |
- length(x[is_keep & x < threshold])+ out <- unique(c(out, out_tmp)) |
| 75 | -36x | +
- } else if (!lower_tail && include_eq) {
+ } |
|
| 76 | -14x | +
- length(x[is_keep & x >= threshold])+ |
|
| 77 | -36x | +
- } else if (!lower_tail && !include_eq) {
+ # If you added pval to the stats_in you certainly want it |
|
| 78 | -15x | +613x |
- length(x[is_keep & x > threshold])+ if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
|
| 79 | -+ | 22x |
- }+ stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
|
| 81 | -36x | +
- result <- c(+ # Must be only one value between choices |
|
| 82 | -36x | +22x |
- count = count,+ checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
|
| 83 | -36x | +
- fraction = if (count == 0 && .N_col == 0) 0 else count / .N_col+ |
|
| 84 |
- )+ # Mismatch with counts and numeric |
||
| 85 | -36x | +21x |
- result+ if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
|
| 86 | -+ | 21x |
- }+ any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
|
| 87 | -+ | 2x |
-
+ stop( |
| 88 | -+ | 2x |
- #' Description of cumulative count+ "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
|
| 89 | -+ | 2x |
- #'+ type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")), |
| 90 | -+ | 2x |
- #' @description `r lifecycle::badge("stable")`
+ " instead." |
| 91 |
- #'+ ) |
||
| 92 |
- #' This is a helper function that describes the analysis in [s_count_cumulative()].+ } |
||
| 93 |
- #'+ |
||
| 94 |
- #' @inheritParams h_count_cumulative+ # Lets add it even if present (thanks to unique) |
||
| 95 | -+ | 19x |
- #'+ add_pval <- TRUE |
| 96 |
- #' @return Labels for [s_count_cumulative()].+ } |
||
| 97 |
- #'+ |
||
| 98 |
- #' @export+ # Mainly used in "analyze_vars" but it could be necessary elsewhere |
||
| 99 | -+ | 610x |
- d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) {
+ if (isTRUE(add_pval)) {
|
| 100 | -34x | +29x |
- checkmate::assert_numeric(threshold)+ if (any(grepl("counts", method_groups))) {
|
| 101 | -34x | +16x |
- lg <- if (lower_tail) "<" else ">"+ out <- unique(c(out, "pval_counts")) |
| 102 | -34x | +
- eq <- if (include_eq) "=" else ""+ } else {
|
|
| 103 | -34x | +13x |
- paste0(lg, eq, " ", threshold)+ out <- unique(c(out, "pval")) |
| 104 |
- }+ } |
||
| 105 |
-
+ } |
||
| 106 |
- #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds.+ |
||
| 107 |
- #'+ # Filtering for stats_in (character vector) |
||
| 108 | -+ | 610x |
- #' @return+ if (!is.null(stats_in)) {
|
| 109 | -+ | 558x |
- #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a+ out <- intersect(stats_in, out) # It orders them too |
| 110 |
- #' component, each component containing a vector for the count and fraction.+ } |
||
| 111 |
- #'+ |
||
| 112 |
- #' @keywords internal+ # If intersect did not find matches (and no pval?) -> error |
||
| 113 | -+ | 610x |
- s_count_cumulative <- function(x,+ if (length(out) == 0) {
|
| 114 | -+ | 2x |
- thresholds,+ stop( |
| 115 | -+ | 2x |
- lower_tail = TRUE,+ "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
|
| 116 | -+ | 2x |
- include_eq = TRUE,+ " do not have the required default statistical methods:\n", |
| 117 | -+ | 2x |
- .N_col, # nolint+ paste0(stats_in, collapse = " ") |
| 118 |
- .N_row, # nolint+ ) |
||
| 119 |
- denom = c("N_col", "n", "N_row"),
+ } |
||
| 120 |
- ...) {
+
|
||
| 121 | -9x | +608x |
- checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)+ out |
| 122 |
-
+ } |
||
| 123 | -9x | +
- denom <- match.arg(denom) %>%+ |
|
| 124 | -9x | +
- switch(+ #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics. |
|
| 125 | -9x | +
- n = length(x),+ #' To check available defaults see `tern::tern_default_formats` list. |
|
| 126 | -9x | +
- N_row = .N_row,+ #' |
|
| 127 | -9x | +
- N_col = .N_col+ #' @param formats_in (named `vector`)\cr inserted formats to replace defaults. It can be a |
|
| 128 |
- )+ #' character vector from [formatters::list_valid_format_labels()] or a custom format function. |
||
| 129 |
-
+ #' |
||
| 130 | -9x | +
- count_fraction_list <- Map(function(thres) {
+ #' @return |
|
| 131 | -18x | +
- result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = denom, ...)+ #' * `get_formats_from_stats()` returns a named vector of formats (if present in either |
|
| 132 | -18x | +
- label <- d_count_cumulative(thres, lower_tail, include_eq)+ #' `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from |
|
| 133 | -18x | +
- formatters::with_label(result, label)+ #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]). |
|
| 134 | -9x | +
- }, thresholds)+ #' |
|
| 135 |
-
+ #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and |
||
| 136 | -9x | +
- names(count_fraction_list) <- thresholds+ #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
|
|
| 137 | -9x | +
- list(count_fraction = count_fraction_list)+ #' |
|
| 138 |
- }+ #' @examples |
||
| 139 |
-
+ #' # Defaults formats |
||
| 140 |
- #' @describeIn count_cumulative Formatted analysis function which is used as `afun`+ #' get_formats_from_stats(num_stats) |
||
| 141 |
- #' in `count_cumulative()`.+ #' get_formats_from_stats(cnt_stats) |
||
| 142 |
- #'+ #' get_formats_from_stats(only_pval) |
||
| 143 |
- #' @return+ #' get_formats_from_stats(all_cnt_occ) |
||
| 144 |
- #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 145 |
- #'+ #' # Addition of customs |
||
| 146 |
- #' @keywords internal+ #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
|
||
| 147 |
- a_count_cumulative <- make_afun(+ #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
|
||
| 148 |
- s_count_cumulative,+ #' |
||
| 149 |
- .formats = c(count_fraction = format_count_fraction)+ #' @seealso [formatting_functions] |
||
| 150 |
- )+ #' |
||
| 151 |
-
+ #' @export |
||
| 152 |
- #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments+ get_formats_from_stats <- function(stats, formats_in = NULL) {
|
||
| 153 | -+ | 601x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ checkmate::assert_character(stats, min.len = 1) |
| 154 |
- #'+ # It may be a list if there is a function in the formats |
||
| 155 | -+ | 601x |
- #' @return+ if (checkmate::test_list(formats_in, null.ok = TRUE)) {
|
| 156 | -+ | 524x |
- #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions,+ checkmate::assert_list(formats_in, null.ok = TRUE) |
| 157 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ # Or it may be a vector of characters |
||
| 158 |
- #' the statistics from `s_count_cumulative()` to the table layout.+ } else {
|
||
| 159 | -+ | 77x |
- #'+ checkmate::assert_character(formats_in, null.ok = TRUE) |
| 160 |
- #' @examples+ } |
||
| 161 |
- #' basic_table() %>%+ |
||
| 162 |
- #' split_cols_by("ARM") %>%
+ # Extract global defaults |
||
| 163 | -+ | 601x |
- #' add_colcounts() %>%+ which_fmt <- match(stats, names(tern_default_formats)) |
| 164 |
- #' count_cumulative(+ |
||
| 165 |
- #' vars = "AGE",+ # Select only needed formats from stats |
||
| 166 | -+ | 601x |
- #' thresholds = c(40, 60)+ ret <- vector("list", length = length(stats)) # Returning a list is simpler
|
| 167 | -+ | 601x |
- #' ) %>%+ ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]] |
| 168 |
- #' build_table(tern_ex_adsl)+ |
||
| 169 | -+ | 601x |
- #'+ out <- setNames(ret, stats) |
| 170 |
- #' @export+ |
||
| 171 |
- #' @order 2+ # Modify some with custom formats |
||
| 172 | -+ | 601x |
- count_cumulative <- function(lyt,+ if (!is.null(formats_in)) {
|
| 173 |
- vars,+ # Stats is the main |
||
| 174 | -+ | 167x |
- thresholds,+ common_names <- intersect(names(out), names(formats_in)) |
| 175 | -+ | 167x |
- lower_tail = TRUE,+ out[common_names] <- formats_in[common_names] |
| 176 |
- include_eq = TRUE,+ } |
||
| 177 |
- var_labels = vars,+ |
||
| 178 | -+ | 601x |
- show_labels = "visible",+ out |
| 179 |
- na_str = default_na_str(),+ } |
||
| 180 |
- nested = TRUE,+ |
||
| 181 |
- ...,+ #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics. |
||
| 182 |
- table_names = vars,+ #' To check for available defaults see `tern::tern_default_labels` list. If not available there, |
||
| 183 |
- .stats = NULL,+ #' the statistics name will be used as label. |
||
| 184 |
- .formats = NULL,+ #' |
||
| 185 |
- .labels = NULL,+ #' @param labels_in (named `character`)\cr inserted labels to replace defaults. |
||
| 186 |
- .indent_mods = NULL) {
+ #' @param row_nms (`character`)\cr row names. Levels of a `factor` or `character` variable, each |
||
| 187 | -3x | +
- extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...)+ #' of which the statistics in `.stats` will be calculated for. If this parameter is set, these |
|
| 188 |
-
+ #' variable levels will be used as the defaults, and the names of the given custom values should |
||
| 189 | -3x | +
- afun <- make_afun(+ #' correspond to levels (or have format `statistic.level`) instead of statistics. Can also be |
|
| 190 | -3x | +
- a_count_cumulative,+ #' variable names if rows correspond to different variables instead of levels. Defaults to `NULL`. |
|
| 191 | -3x | +
- .stats = .stats,+ #' |
|
| 192 | -3x | +
- .formats = .formats,+ #' @return |
|
| 193 | -3x | +
- .labels = .labels,+ #' * `get_labels_from_stats()` returns a named `character` vector of labels (if present in either |
|
| 194 | -3x | +
- .indent_mods = .indent_mods,+ #' `tern_default_labels` or `labels_in`, otherwise `NULL`). |
|
| 195 | -3x | +
- .ungroup_stats = "count_fraction"+ #' |
|
| 196 |
- )+ #' @examples |
||
| 197 | -3x | +
- analyze(+ #' # Defaults labels |
|
| 198 | -3x | +
- lyt,+ #' get_labels_from_stats(num_stats) |
|
| 199 | -3x | +
- vars,+ #' get_labels_from_stats(cnt_stats) |
|
| 200 | -3x | +
- afun = afun,+ #' get_labels_from_stats(only_pval) |
|
| 201 | -3x | +
- na_str = na_str,+ #' get_labels_from_stats(all_cnt_occ) |
|
| 202 | -3x | +
- table_names = table_names,+ #' |
|
| 203 | -3x | +
- var_labels = var_labels,+ #' # Addition of customs |
|
| 204 | -3x | +
- show_labels = show_labels,+ #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
|
|
| 205 | -3x | +
- nested = nested,+ #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
|
|
| 206 | -3x | +
- extra_args = extra_args+ #' |
|
| 207 |
- )+ #' @export |
||
| 208 |
- }- |
-
| 1 | -- |
- #' Odds ratio estimation+ get_labels_from_stats <- function(stats, labels_in = NULL, row_nms = NULL) {
|
||
| 2 | -+ | |||
| 209 | +590x |
- #'+ checkmate::assert_character(stats, min.len = 1) |
||
| 3 | -+ | |||
| 210 | +590x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_character(row_nms, null.ok = TRUE) |
||
| 4 | +211 |
- #'+ # It may be a list |
||
| 5 | -+ | |||
| 212 | +590x |
- #' The analyze function [estimate_odds_ratio()] creates a layout element to compare bivariate responses between+ if (checkmate::test_list(labels_in, null.ok = TRUE)) {
|
||
| 6 | -+ | |||
| 213 | +485x |
- #' two groups by estimating an odds ratio and its confidence interval.+ checkmate::assert_list(labels_in, null.ok = TRUE) |
||
| 7 | +214 |
- #'+ # Or it may be a vector of characters |
||
| 8 | +215 |
- #' The primary analysis variable specified by `vars` is the group variable. Additional variables can be included in the+ } else {
|
||
| 9 | -+ | |||
| 216 | +105x |
- #' analysis via the `variables` argument, which accepts `arm`, an arm variable, and `strata`, a stratification variable.+ checkmate::assert_character(labels_in, null.ok = TRUE) |
||
| 10 | +217 |
- #' If more than two arm levels are present, they can be combined into two groups using the `groups_list` argument.+ } |
||
| 11 | +218 |
- #'+ |
||
| 12 | -+ | |||
| 219 | +590x |
- #' @inheritParams split_cols_by_groups+ if (!is.null(row_nms)) {
|
||
| 13 | -+ | |||
| 220 | +170x |
- #' @inheritParams argument_convention+ ret <- rep(row_nms, length(stats)) |
||
| 14 | -+ | |||
| 221 | +170x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ out <- setNames(ret, paste(rep(stats, each = length(row_nms)), ret, sep = ".")) |
||
| 15 | +222 |
- #'+ |
||
| 16 | -+ | |||
| 223 | +170x |
- #' Options are: ``r shQuote(get_stats("estimate_odds_ratio"))``
+ if (!is.null(labels_in)) {
|
||
| 17 | -+ | |||
| 224 | +4x |
- #' @param method (`string`)\cr whether to use the correct (`"exact"`) calculation in the conditional likelihood or one+ lvl_lbls <- intersect(names(labels_in), row_nms) |
||
| 18 | -+ | |||
| 225 | +4x |
- #' of the approximations. See [survival::clogit()] for details.+ for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- labels_in[[i]] |
||
| 19 | +226 |
- #'+ } |
||
| 20 | +227 |
- #' @note+ } else {
|
||
| 21 | -+ | |||
| 228 | +420x |
- #' * This function uses logistic regression for unstratified analyses, and conditional logistic regression for+ which_lbl <- match(stats, names(tern_default_labels)) |
||
| 22 | +229 |
- #' stratified analyses. The Wald confidence interval is calculated with the specified confidence level.+ |
||
| 23 | -+ | |||
| 230 | +420x |
- #' * For stratified analyses, there is currently no implementation for conditional likelihood confidence intervals,+ ret <- stats # The default |
||
| 24 | -+ | |||
| 231 | +420x |
- #' therefore the likelihood confidence interval is not available as an option.+ ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]] |
||
| 25 | +232 |
- #' * When `vars` contains only responders or non-responders no odds ratio estimation is possible so the returned+ |
||
| 26 | -+ | |||
| 233 | +420x |
- #' values will be `NA`.+ out <- setNames(ret, stats) |
||
| 27 | +234 |
- #'+ } |
||
| 28 | +235 |
- #' @seealso Relevant helper function [h_odds_ratio()].+ |
||
| 29 | +236 |
- #'+ # Modify some with custom labels |
||
| 30 | -+ | |||
| 237 | +590x |
- #' @name odds_ratio+ if (!is.null(labels_in)) {
|
||
| 31 | +238 |
- #' @order 1+ # Stats is the main |
||
| 32 | -+ | |||
| 239 | +110x |
- NULL+ common_names <- intersect(names(out), names(labels_in)) |
||
| 33 | -+ | |||
| 240 | +110x |
-
+ out[common_names] <- labels_in[common_names] |
||
| 34 | +241 |
- #' @describeIn odds_ratio Statistics function which estimates the odds ratio+ } |
||
| 35 | +242 |
- #' between a treatment and a control. A `variables` list with `arm` and `strata`+ |
||
| 36 | -+ | |||
| 243 | +590x |
- #' variable names must be passed if a stratified analysis is required.+ out |
||
| 37 | +244 |
- #'+ } |
||
| 38 | +245 |
- #' @return+ |
||
| 39 | +246 |
- #' * `s_odds_ratio()` returns a named list with the statistics `or_ci`+ #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics. |
||
| 40 | +247 |
- #' (containing `est`, `lcl`, and `ucl`) and `n_tot`.+ #' It defaults to 0L for all values. |
||
| 41 | +248 |
#' |
||
| 42 | +249 |
- #' @examples+ #' @param indents_in (named `vector`)\cr inserted indent modifiers to replace defaults (default is `0L`). |
||
| 43 | +250 |
- #' # Unstratified analysis.+ #' |
||
| 44 | +251 |
- #' s_odds_ratio(+ #' @return |
||
| 45 | +252 |
- #' df = subset(dta, grp == "A"),+ #' * `get_indents_from_stats()` returns a single indent modifier value to apply to all rows |
||
| 46 | +253 |
- #' .var = "rsp",+ #' or a named numeric vector of indent modifiers (if present, otherwise `NULL`). |
||
| 47 | +254 |
- #' .ref_group = subset(dta, grp == "B"),+ #' |
||
| 48 | +255 |
- #' .in_ref_col = FALSE,+ #' @examples |
||
| 49 | +256 |
- #' .df_row = dta+ #' get_indents_from_stats(all_cnt_occ, indents_in = 3L) |
||
| 50 | +257 |
- #' )+ #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L)) |
||
| 51 | +258 |
- #'+ #' get_indents_from_stats( |
||
| 52 | +259 |
- #' # Stratified analysis.+ #' all_cnt_occ, |
||
| 53 | +260 |
- #' s_odds_ratio(+ #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L), row_nms = c("a", "b")
|
||
| 54 | +261 |
- #' df = subset(dta, grp == "A"),+ #' ) |
||
| 55 | +262 |
- #' .var = "rsp",+ #' |
||
| 56 | +263 |
- #' .ref_group = subset(dta, grp == "B"),+ #' @export |
||
| 57 | +264 |
- #' .in_ref_col = FALSE,+ get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
|
||
| 58 | -+ | |||
| 265 | +550x |
- #' .df_row = dta,+ checkmate::assert_character(stats, min.len = 1) |
||
| 59 | -+ | |||
| 266 | +550x |
- #' variables = list(arm = "grp", strata = "strata")+ checkmate::assert_character(row_nms, null.ok = TRUE) |
||
| 60 | +267 |
- #' )+ # It may be a list |
||
| 61 | -+ | |||
| 268 | +550x |
- #'+ if (checkmate::test_list(indents_in, null.ok = TRUE)) {
|
||
| 62 | -+ | |||
| 269 | +497x |
- #' @export+ checkmate::assert_list(indents_in, null.ok = TRUE) |
||
| 63 | +270 |
- s_odds_ratio <- function(df,+ # Or it may be a vector of integers |
||
| 64 | +271 |
- .var,+ } else {
|
||
| 65 | -+ | |||
| 272 | +53x |
- .ref_group,+ checkmate::assert_integerish(indents_in, null.ok = TRUE) |
||
| 66 | +273 |
- .in_ref_col,+ } |
||
| 67 | +274 |
- .df_row,+ |
||
| 68 | -+ | |||
| 275 | +550x |
- variables = list(arm = NULL, strata = NULL),+ if (is.null(names(indents_in)) && length(indents_in) == 1) {
|
||
| 69 | -+ | |||
| 276 | +20x |
- conf_level = 0.95,+ out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1) |
||
| 70 | -+ | |||
| 277 | +20x |
- groups_list = NULL,+ return(out) |
||
| 71 | +278 |
- method = "exact") {
- |
- ||
| 72 | -87x | -
- y <- list(or_ci = "", n_tot = "")+ } |
||
| 73 | +279 | |||
| 74 | -87x | -
- if (!.in_ref_col) {
- |
- ||
| 75 | -87x | +280 | +530x |
- assert_proportion_value(conf_level)+ if (!is.null(row_nms)) {
|
| 76 | -87x | +281 | +153x |
- assert_df_with_variables(df, list(rsp = .var))+ ret <- rep(0L, length(stats) * length(row_nms)) |
| 77 | -87x | +282 | +153x |
- assert_df_with_variables(.ref_group, list(rsp = .var))+ out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = ".")) |
| 78 | +283 | |||
| 79 | -87x | +284 | +153x |
- if (is.null(variables$strata)) {
+ if (!is.null(indents_in)) {
|
| 80 | -72x | +285 | +4x |
- data <- data.frame(+ lvl_lbls <- intersect(names(indents_in), row_nms) |
| 81 | -72x | +286 | +4x |
- rsp = c(.ref_group[[.var]], df[[.var]]),+ for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]] |
| 82 | -72x | +|||
| 287 | +
- grp = factor(+ }+ |
+ |||
| 288 | ++ |
+ } else {
|
||
| 83 | -72x | +289 | +377x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ ret <- rep(0L, length(stats)) |
| 84 | -72x | +290 | +377x |
- levels = c("ref", "Not-ref")
+ out <- setNames(ret, stats) |
| 85 | +291 |
- )+ } |
||
| 86 | +292 |
- )+ + |
+ ||
| 293 | ++ |
+ # Modify some with custom labels |
||
| 87 | -72x | +294 | +530x |
- y <- or_glm(data, conf_level = conf_level)+ if (!is.null(indents_in)) {
|
| 88 | +295 |
- } else {
+ # Stats is the main |
||
| 89 | -15x | +296 | +37x |
- assert_df_with_variables(.df_row, c(list(rsp = .var), variables))+ common_names <- intersect(names(out), names(indents_in)) |
| 90 | -15x | +297 | +37x |
- checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
+ out[common_names] <- indents_in[common_names] |
| 91 | +298 |
-
+ } |
||
| 92 | +299 |
- # The group variable prepared for clogit must be synchronised with combination groups definition.+ |
||
| 93 | -15x | +300 | +530x |
- if (is.null(groups_list)) {
+ out |
| 94 | -14x | +|||
| 301 | +
- ref_grp <- as.character(unique(.ref_group[[variables$arm]]))+ } |
|||
| 95 | -14x | +|||
| 302 | +
- trt_grp <- as.character(unique(df[[variables$arm]]))+ |
|||
| 96 | -14x | +|||
| 303 | +
- grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)+ #' Update labels according to control specifications |
|||
| 97 | +304 |
- } else {
+ #' |
||
| 98 | +305 |
- # If more than one level in reference col.+ #' @description `r lifecycle::badge("stable")`
|
||
| 99 | -1x | +|||
| 306 | +
- reference <- as.character(unique(.ref_group[[variables$arm]]))+ #' |
|||
| 100 | -1x | +|||
| 307 | +
- grp_ref_flag <- vapply(+ #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant |
|||
| 101 | -1x | +|||
| 308 | +
- X = groups_list,+ #' control specification. For example, if control has element `conf_level` set to `0.9`, the default |
|||
| 102 | -1x | +|||
| 309 | +
- FUN.VALUE = TRUE,+ #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied |
|||
| 103 | -1x | +|||
| 310 | +
- FUN = function(x) all(reference %in% x)+ #' via `labels_custom` will not be updated regardless of `control`. |
|||
| 104 | +311 |
- )+ #' |
||
| 105 | -1x | +|||
| 312 | +
- ref_grp <- names(groups_list)[grp_ref_flag]+ #' @param labels_default (named `character`)\cr a named vector of statistic labels to modify |
|||
| 106 | +313 |
-
+ #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will |
||
| 107 | +314 |
- # If more than one level in treatment col.+ #' not be affected. |
||
| 108 | -1x | +|||
| 315 | +
- treatment <- as.character(unique(df[[variables$arm]]))+ #' @param labels_custom (named `character`)\cr named vector of labels that are customized by |
|||
| 109 | -1x | +|||
| 316 | +
- grp_trt_flag <- vapply(+ #' the user and should not be affected by `control`. |
|||
| 110 | -1x | +|||
| 317 | +
- X = groups_list,+ #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels. |
|||
| 111 | -1x | +|||
| 318 | +
- FUN.VALUE = TRUE,+ #' |
|||
| 112 | -1x | +|||
| 319 | +
- FUN = function(x) all(treatment %in% x)+ #' @return A named character vector of labels with control specifications applied to relevant labels. |
|||
| 113 | +320 |
- )+ #' |
||
| 114 | -1x | +|||
| 321 | +
- trt_grp <- names(groups_list)[grp_trt_flag]+ #' @examples |
|||
| 115 | +322 |
-
+ #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57) |
||
| 116 | -1x | +|||
| 323 | +
- grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)+ #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
|
|||
| 117 | -1x | +|||
| 324 | +
- grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)+ #' labels_use_control(control = control) |
|||
| 118 | +325 |
- }+ #' |
||
| 119 | +326 |
-
+ #' @export |
||
| 120 | +327 |
- # The reference level in `grp` must be the same as in the `rtables` column split.+ labels_use_control <- function(labels_default, control, labels_custom = NULL) {
|
||
| 121 | -15x | +328 | +20x |
- data <- data.frame(+ if ("conf_level" %in% names(control)) {
|
| 122 | -15x | +329 | +20x |
- rsp = .df_row[[.var]],+ labels_default <- sapply( |
| 123 | -15x | +330 | +20x |
- grp = grp,+ names(labels_default), |
| 124 | -15x | +331 | +20x |
- strata = interaction(.df_row[variables$strata])+ function(x) {
|
| 125 | -+ | |||
| 332 | +91x |
- )+ if (!x %in% names(labels_custom)) {
|
||
| 126 | -15x | +333 | +88x |
- y_all <- or_clogit(data, conf_level = conf_level, method = method)+ gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]])) |
| 127 | -15x | +|||
| 334 | +
- checkmate::assert_string(trt_grp)+ } else {
|
|||
| 128 | -15x | +335 | +3x |
- checkmate::assert_subset(trt_grp, names(y_all$or_ci))+ labels_default[[x]] |
| 129 | -14x | +|||
| 336 | +
- y$or_ci <- y_all$or_ci[[trt_grp]]+ } |
|||
| 130 | -14x | +|||
| 337 | +
- y$n_tot <- y_all$n_tot+ } |
|||
| 131 | +338 |
- }+ ) |
||
| 132 | +339 |
} |
||
| 133 | -+ | |||
| 340 | +20x |
-
+ if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
|
||
| 134 | -86x | +341 | +20x |
- if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && method != "approximate") {
+ !"quantiles" %in% names(labels_custom)) { # nolint
|
| 135 | -1x | +342 | +16x |
- warning(+ labels_default["quantiles"] <- gsub( |
| 136 | -1x | +343 | +16x |
- "Unable to compute the odds ratio estimate. Please try re-running the function with ",+ "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""), |
| 137 | -1x | +344 | +16x |
- 'parameter `method` set to "approximate".'+ labels_default["quantiles"] |
| 138 | +345 |
) |
||
| 139 | +346 |
} |
||
| 140 | -+ | |||
| 347 | +20x |
-
+ if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
|
||
| 141 | -86x | +348 | +20x |
- y$or_ci <- formatters::with_label(+ !"mean_pval" %in% names(labels_custom)) { # nolint
|
| 142 | -86x | +349 | +2x |
- x = y$or_ci,+ labels_default["mean_pval"] <- gsub( |
| 143 | -86x | +350 | +2x |
- label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
+ "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"] |
| 144 | +351 |
- )+ ) |
||
| 145 | +352 |
-
+ } |
||
| 146 | -86x | +|||
| 353 | +
- y$n_tot <- formatters::with_label(+ |
|||
| 147 | -86x | +354 | +20x |
- x = y$n_tot,+ labels_default |
| 148 | -86x | +|||
| 355 | +
- label = "Total n"+ } |
|||
| 149 | +356 |
- )+ |
||
| 150 | +357 |
-
+ #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`. |
||
| 151 | -86x | +|||
| 358 | +
- y+ #' |
|||
| 152 | +359 |
- }+ #' @format |
||
| 153 | +360 |
-
+ #' * `tern_default_stats` is a named list of available statistics, with each element |
||
| 154 | +361 |
- #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`.+ #' named for their corresponding statistical method group. |
||
| 155 | +362 |
#' |
||
| 156 | +363 |
- #' @return+ #' @export |
||
| 157 | +364 |
- #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()].+ tern_default_stats <- list( |
||
| 158 | +365 |
- #'+ abnormal = c("fraction"),
|
||
| 159 | +366 |
- #' @examples+ abnormal_by_baseline = c("fraction"),
|
||
| 160 | +367 |
- #' a_odds_ratio(+ abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 161 | +368 |
- #' df = subset(dta, grp == "A"),+ abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 162 | +369 |
- #' .var = "rsp",+ abnormal_by_worst_grade_worsen = c("fraction"),
|
||
| 163 | +370 |
- #' .ref_group = subset(dta, grp == "B"),+ analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
|
||
| 164 | +371 |
- #' .in_ref_col = FALSE,+ analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "fraction", "n_blq"),
|
||
| 165 | +372 |
- #' .df_row = dta+ analyze_vars_numeric = c( |
||
| 166 | +373 |
- #' )+ "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval", |
||
| 167 | +374 |
- #'+ "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv", |
||
| 168 | +375 |
- #' @export+ "geom_mean", "geom_mean_ci", "geom_cv" |
||
| 169 | +376 |
- a_odds_ratio <- make_afun(+ ), |
||
| 170 | +377 |
- s_odds_ratio,+ count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 171 | +378 |
- .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"),+ count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
|
||
| 172 | +379 |
- .indent_mods = c(or_ci = 1L)+ count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
|
||
| 173 | +380 |
- )+ count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 174 | +381 |
-
+ count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 175 | +382 |
- #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments+ count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 176 | +383 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 177 | +384 |
- #'+ coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
|
||
| 178 | +385 |
- #' @return+ estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci", "n_unique", "n_rate"),
|
||
| 179 | +386 |
- #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions,+ estimate_multinomial_response = c("n_prop", "prop_ci"),
|
||
| 180 | +387 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ estimate_odds_ratio = c("or_ci", "n_tot"),
|
||
| 181 | +388 |
- #' the statistics from `s_odds_ratio()` to the table layout.+ estimate_proportion = c("n_prop", "prop_ci"),
|
||
| 182 | +389 |
- #'+ estimate_proportion_diff = c("diff", "diff_ci"),
|
||
| 183 | +390 |
- #' @examples+ summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
|
||
| 184 | +391 |
- #' set.seed(12)+ summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
|
||
| 185 | +392 |
- #' dta <- data.frame(+ summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 186 | +393 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ summarize_num_patients = c("unique", "nonunique", "unique_count"),
|
||
| 187 | +394 |
- #' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
+ summarize_patients_events_in_cols = c("unique", "all"),
|
||
| 188 | +395 |
- #' strata = factor(sample(c("C", "D"), 100, TRUE))
+ surv_time = c("median", "median_ci", "quantiles", "range_censor", "range_event", "range"),
|
||
| 189 | +396 |
- #' )+ surv_timepoint = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval"),
|
||
| 190 | +397 |
- #'+ tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
||
| 191 | +398 |
- #' l <- basic_table() %>%+ tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
|
||
| 192 | +399 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 193 | +400 |
- #' estimate_odds_ratio(vars = "rsp")+ tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
|
||
| 194 | +401 |
- #'+ test_proportion_diff = c("pval")
|
||
| 195 | +402 |
- #' build_table(l, df = dta)+ ) |
||
| 196 | +403 |
- #'+ |
||
| 197 | +404 |
- #' @export+ #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`. |
||
| 198 | +405 |
- #' @order 2+ #' |
||
| 199 | +406 |
- estimate_odds_ratio <- function(lyt,+ #' @format |
||
| 200 | +407 |
- vars,+ #' * `tern_default_formats` is a named vector of available default formats, with each element |
||
| 201 | +408 |
- variables = list(arm = NULL, strata = NULL),+ #' named for their corresponding statistic. |
||
| 202 | +409 |
- conf_level = 0.95,+ #' |
||
| 203 | +410 |
- groups_list = NULL,+ #' @export |
||
| 204 | +411 |
- na_str = default_na_str(),+ tern_default_formats <- c( |
||
| 205 | +412 |
- nested = TRUE,+ fraction = format_fraction_fixed_dp, |
||
| 206 | +413 |
- method = "exact",+ unique = format_count_fraction_fixed_dp, |
||
| 207 | +414 |
- show_labels = "hidden",+ nonunique = "xx", |
||
| 208 | +415 |
- table_names = vars,+ unique_count = "xx", |
||
| 209 | +416 |
- var_labels = vars,+ n = "xx.", |
||
| 210 | +417 |
- .stats = "or_ci",+ count = "xx.", |
||
| 211 | +418 |
- .formats = NULL,+ count_fraction = format_count_fraction, |
||
| 212 | +419 |
- .labels = NULL,+ count_fraction_fixed_dp = format_count_fraction_fixed_dp, |
||
| 213 | +420 |
- .indent_mods = NULL) {
- |
- ||
| 214 | -5x | -
- extra_args <- list(variables = variables, conf_level = conf_level, groups_list = groups_list, method = method)+ n_blq = "xx.", |
||
| 215 | +421 | - - | -||
| 216 | -5x | -
- afun <- make_afun(- |
- ||
| 217 | -5x | -
- a_odds_ratio,- |
- ||
| 218 | -5x | -
- .stats = .stats,- |
- ||
| 219 | -5x | -
- .formats = .formats,+ sum = "xx.x", |
||
| 220 | -5x | +|||
| 422 | +
- .labels = .labels,+ mean = "xx.x", |
|||
| 221 | -5x | +|||
| 423 | +
- .indent_mods = .indent_mods+ sd = "xx.x", |
|||
| 222 | +424 |
- )+ se = "xx.x", |
||
| 223 | +425 |
-
+ mean_sd = "xx.x (xx.x)", |
||
| 224 | -5x | +|||
| 426 | +
- analyze(+ mean_se = "xx.x (xx.x)", |
|||
| 225 | -5x | +|||
| 427 | +
- lyt,+ mean_ci = "(xx.xx, xx.xx)", |
|||
| 226 | -5x | +|||
| 428 | +
- vars,+ mean_sei = "(xx.xx, xx.xx)", |
|||
| 227 | -5x | +|||
| 429 | +
- afun = afun,+ mean_sdi = "(xx.xx, xx.xx)", |
|||
| 228 | -5x | +|||
| 430 | +
- var_labels = var_labels,+ mean_pval = "x.xxxx | (<0.0001)", |
|||
| 229 | -5x | +|||
| 431 | +
- na_str = na_str,+ median = "xx.x", |
|||
| 230 | -5x | +|||
| 432 | +
- nested = nested,+ mad = "xx.x", |
|||
| 231 | -5x | +|||
| 433 | +
- extra_args = extra_args,+ median_ci = "(xx.xx, xx.xx)", |
|||
| 232 | -5x | +|||
| 434 | +
- show_labels = show_labels,+ quantiles = "xx.x - xx.x", |
|||
| 233 | -5x | +|||
| 435 | +
- table_names = table_names+ iqr = "xx.x", |
|||
| 234 | +436 |
- )+ range = "xx.x - xx.x", |
||
| 235 | +437 |
- }+ min = "xx.x", |
||
| 236 | +438 |
-
+ max = "xx.x", |
||
| 237 | +439 |
- #' Helper functions for odds ratio estimation+ median_range = "xx.x (xx.x - xx.x)", |
||
| 238 | +440 |
- #'+ cv = "xx.x", |
||
| 239 | +441 |
- #' @description `r lifecycle::badge("stable")`
+ geom_mean = "xx.x", |
||
| 240 | +442 |
- #'+ geom_mean_ci = "(xx.xx, xx.xx)", |
||
| 241 | +443 |
- #' Functions to calculate odds ratios in [estimate_odds_ratio()].+ geom_cv = "xx.x", |
||
| 242 | +444 |
- #'+ pval = "x.xxxx | (<0.0001)", |
||
| 243 | +445 |
- #' @inheritParams odds_ratio+ pval_counts = "x.xxxx | (<0.0001)", |
||
| 244 | +446 |
- #' @inheritParams argument_convention+ range_censor = "xx.x to xx.x", |
||
| 245 | +447 |
- #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally+ range_event = "xx.x to xx.x", |
||
| 246 | +448 |
- #' `strata` for [or_clogit()].+ rate = "xx.xxxx", |
||
| 247 | +449 |
- #'+ rate_ci = "(xx.xxxx, xx.xxxx)", |
||
| 248 | +450 |
- #' @return A named `list` of elements `or_ci` and `n_tot`.+ rate_ratio = "xx.xxxx", |
||
| 249 | +451 |
- #'+ rate_ratio_ci = "(xx.xxxx, xx.xxxx)" |
||
| 250 | +452 |
- #' @seealso [odds_ratio]+ ) |
||
| 251 | +453 |
- #'+ |
||
| 252 | +454 |
- #' @name h_odds_ratio+ #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`. |
||
| 253 | +455 |
- NULL+ #' |
||
| 254 | +456 |
-
+ #' @format |
||
| 255 | +457 |
- #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be+ #' * `tern_default_labels` is a named `character` vector of available default labels, with each element |
||
| 256 | +458 |
- #' exactly 2 groups in `data` as specified by the `grp` variable.+ #' named for their corresponding statistic. |
||
| 257 | +459 |
#' |
||
| 258 | +460 |
- #' @examples+ #' @export |
||
| 259 | +461 |
- #' # Data with 2 groups.+ tern_default_labels <- c( |
||
| 260 | +462 |
- #' data <- data.frame(+ fraction = "fraction", |
||
| 261 | +463 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),+ unique = "Number of patients with at least one event", |
||
| 262 | +464 |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],+ nonunique = "Number of events", |
||
| 263 | +465 |
- #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],+ n = "n", |
||
| 264 | +466 |
- #' stringsAsFactors = TRUE+ count = "count", |
||
| 265 | +467 |
- #' )+ count_fraction = "count_fraction", |
||
| 266 | +468 |
- #'+ count_fraction_fixed_dp = "count_fraction", |
||
| 267 | +469 |
- #' # Odds ratio based on glm.+ n_blq = "n_blq", |
||
| 268 | +470 |
- #' or_glm(data, conf_level = 0.95)+ sum = "Sum", |
||
| 269 | +471 |
- #'+ mean = "Mean", |
||
| 270 | +472 |
- #' @export+ sd = "SD", |
||
| 271 | +473 |
- or_glm <- function(data, conf_level) {
- |
- ||
| 272 | -77x | -
- checkmate::assert_logical(data$rsp)+ se = "SE", |
||
| 273 | -77x | +|||
| 474 | +
- assert_proportion_value(conf_level)+ mean_sd = "Mean (SD)", |
|||
| 274 | -77x | +|||
| 475 | +
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))+ mean_se = "Mean (SE)", |
|||
| 275 | -77x | +|||
| 476 | +
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ mean_ci = "Mean 95% CI", |
|||
| 276 | +477 |
-
+ mean_sei = "Mean -/+ 1xSE", |
||
| 277 | -77x | +|||
| 478 | +
- data$grp <- as_factor_keep_attributes(data$grp)+ mean_sdi = "Mean -/+ 1xSD", |
|||
| 278 | -77x | +|||
| 479 | +
- assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)+ mean_pval = "Mean p-value (H0: mean = 0)", |
|||
| 279 | -77x | +|||
| 480 | +
- formula <- stats::as.formula("rsp ~ grp")
+ median = "Median", |
|||
| 280 | -77x | +|||
| 481 | +
- model_fit <- stats::glm(+ mad = "Median Absolute Deviation", |
|||
| 281 | -77x | +|||
| 482 | +
- formula = formula, data = data,+ median_ci = "Median 95% CI", |
|||
| 282 | -77x | +|||
| 483 | +
- family = stats::binomial(link = "logit")+ quantiles = "25% and 75%-ile", |
|||
| 283 | +484 |
- )+ iqr = "IQR", |
||
| 284 | +485 |
-
+ range = "Min - Max", |
||
| 285 | +486 |
- # Note that here we need to discard the intercept.+ min = "Minimum", |
||
| 286 | -77x | +|||
| 487 | +
- or <- exp(stats::coef(model_fit)[-1])+ max = "Maximum", |
|||
| 287 | -77x | +|||
| 488 | +
- or_ci <- exp(+ median_range = "Median (Min - Max)", |
|||
| 288 | -77x | +|||
| 489 | +
- stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE]+ cv = "CV (%)", |
|||
| 289 | +490 |
- )+ geom_mean = "Geometric Mean", |
||
| 290 | +491 |
-
+ geom_mean_ci = "Geometric Mean 95% CI", |
||
| 291 | -77x | +|||
| 492 | +
- values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
+ geom_cv = "CV % Geometric Mean", |
|||
| 292 | -77x | +|||
| 493 | +
- n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")+ pval = "p-value (t-test)", # Default for numeric |
|||
| 293 | +494 |
-
+ pval_counts = "p-value (chi-squared test)", # Default for counts |
||
| 294 | -77x | +|||
| 495 | +
- list(or_ci = values, n_tot = n_tot)+ rate = "Adjusted Rate", |
|||
| 295 | +496 |
- }+ rate_ratio = "Adjusted Rate Ratio" |
||
| 296 | +497 |
-
+ ) |
||
| 297 | +498 |
- #' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for+ |
||
| 298 | +499 |
- #' the whole data set including all groups, since the results are not the same as when doing+ # To deprecate --------- |
||
| 299 | +500 |
- #' pairwise comparisons between the groups.+ |
||
| 300 | +501 |
- #'+ #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
|
||
| 301 | +502 |
- #' @examples+ #' Quick function to retrieve default formats for summary statistics: |
||
| 302 | +503 |
- #' # Data with 3 groups.+ #' [analyze_vars()] and [analyze_vars_in_cols()] principally. |
||
| 303 | +504 |
- #' data <- data.frame(+ #' |
||
| 304 | +505 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),+ #' @param type (`string`)\cr `"numeric"` or `"counts"`. |
||
| 305 | +506 |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],+ #' |
||
| 306 | +507 |
- #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],+ #' @return |
||
| 307 | +508 |
- #' stringsAsFactors = TRUE+ #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type. |
||
| 308 | +509 |
- #' )+ #' |
||
| 309 | +510 |
- #'+ #' @examples |
||
| 310 | +511 |
- #' # Odds ratio based on stratified estimation by conditional logistic regression.+ #' summary_formats() |
||
| 311 | +512 |
- #' or_clogit(data, conf_level = 0.95)+ #' summary_formats(type = "counts", include_pval = TRUE) |
||
| 312 | +513 |
#' |
||
| 313 | +514 |
#' @export |
||
| 314 | +515 |
- or_clogit <- function(data, conf_level, method = "exact") {
+ summary_formats <- function(type = "numeric", include_pval = FALSE) {
|
||
| 315 | -19x | +516 | +2x |
- checkmate::assert_logical(data$rsp)+ lifecycle::deprecate_warn( |
| 316 | -19x | +517 | +2x |
- assert_proportion_value(conf_level)+ "0.9.6", "summary_formats()", |
| 317 | -19x | +518 | +2x |
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))+ details = 'Use get_formats_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
|
| 318 | -19x | +|||
| 519 | +
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ ) |
|||
| 319 | -19x | +520 | +2x |
- checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 320 | -19x | +521 | +2x |
- checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
+ get_formats_from_stats(get_stats(met_grp, add_pval = include_pval)) |
| 321 | +522 | ++ |
+ }+ |
+ |
| 523 | ||||
| 322 | -19x | +|||
| 524 | +
- data$grp <- as_factor_keep_attributes(data$grp)+ #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
|
|||
| 323 | -19x | +|||
| 525 | +
- data$strata <- as_factor_keep_attributes(data$strata)+ #' Quick function to retrieve default labels for summary statistics. |
|||
| 324 | +526 |
-
+ #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`. |
||
| 325 | +527 |
- # Deviation from convention: `survival::strata` must be simply `strata`.+ #' |
||
| 326 | -19x | +|||
| 528 | +
- formula <- stats::as.formula("rsp ~ grp + strata(strata)")
+ #' @param include_pval (`flag`)\cr same as the `add_pval` argument in [get_stats()]. |
|||
| 327 | -19x | +|||
| 529 | +
- model_fit <- clogit_with_tryCatch(formula = formula, data = data, method = method)+ #' |
|||
| 328 | +530 |
-
+ #' @return |
||
| 329 | +531 |
- # Create a list with one set of OR estimates and CI per coefficient, i.e.+ #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type. |
||
| 330 | +532 |
- # comparison of one group vs. the reference group.+ #' |
||
| 331 | -19x | +|||
| 533 | +
- coef_est <- stats::coef(model_fit)+ #' @examples |
|||
| 332 | -19x | +|||
| 534 | +
- ci_est <- stats::confint(model_fit, level = conf_level)+ #' summary_labels() |
|||
| 333 | -19x | +|||
| 535 | +
- or_ci <- list()+ #' summary_labels(type = "counts", include_pval = TRUE) |
|||
| 334 | -19x | +|||
| 536 | +
- for (coef_name in names(coef_est)) {
+ #' |
|||
| 335 | -21x | +|||
| 537 | +
- grp_name <- gsub("^grp", "", x = coef_name)
+ #' @export+ |
+ |||
| 538 | ++ |
+ summary_labels <- function(type = "numeric", include_pval = FALSE) {
|
||
| 336 | -21x | +539 | +2x |
- or_ci[[grp_name]] <- stats::setNames(+ lifecycle::deprecate_warn( |
| 337 | -21x | +540 | +2x |
- object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])),+ "0.9.6", "summary_formats()", |
| 338 | -21x | +541 | +2x |
- nm = c("est", "lcl", "ucl")
+ details = 'Use get_labels_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
|
| 339 | +542 |
- )+ ) |
||
| 340 | -+ | |||
| 543 | +2x |
- }+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
||
| 341 | -19x | +544 | +2x |
- list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n))+ get_labels_from_stats(get_stats(met_grp, add_pval = include_pval)) |
| 342 | +545 |
}@@ -121929,14 +120256,14 @@ tern coverage - 95.65% |
| 1 |
- #' Re-implemented `range()` default S3 method for numerical objects+ #' Odds ratio estimation |
||
| 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 |
- #'+ #' The analyze function [estimate_odds_ratio()] creates a layout element to compare bivariate responses between |
||
| 6 |
- #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed.+ #' two groups by estimating an odds ratio and its confidence interval. |
||
| 7 |
- #' @param na.rm (`flag`)\cr flag indicating if `NA` should be omitted.+ #' |
||
| 8 |
- #' @param finite (`flag`)\cr flag indicating if non-finite elements should be removed.+ #' The primary analysis variable specified by `vars` is the group variable. Additional variables can be included in the |
||
| 9 |
- #'+ #' analysis via the `variables` argument, which accepts `arm`, an arm variable, and `strata`, a stratification variable. |
||
| 10 |
- #' @return A 2-element vector of class `numeric`.+ #' If more than two arm levels are present, they can be combined into two groups using the `groups_list` argument. |
||
| 12 |
- #' @keywords internal+ #' @inheritParams split_cols_by_groups |
||
| 13 |
- range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
+ #' @inheritParams argument_convention |
||
| 14 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 15 | -1878x | +
- checkmate::assert_numeric(x)+ #' |
|
| 16 |
-
+ #' Options are: ``r shQuote(get_stats("estimate_odds_ratio"))``
|
||
| 17 | -1878x | +
- if (finite) {
+ #' @param method (`string`)\cr whether to use the correct (`"exact"`) calculation in the conditional likelihood or one |
|
| 18 | -24x | +
- x <- x[is.finite(x)] # removes NAs too+ #' of the approximations. See [survival::clogit()] for details. |
|
| 19 | -1854x | +
- } else if (na.rm) {
+ #' |
|
| 20 | -708x | +
- x <- x[!is.na(x)]+ #' @note |
|
| 21 |
- }+ #' * This function uses logistic regression for unstratified analyses, and conditional logistic regression for |
||
| 22 |
-
+ #' stratified analyses. The Wald confidence interval is calculated with the specified confidence level. |
||
| 23 | -1878x | +
- if (length(x) == 0) {
+ #' * For stratified analyses, there is currently no implementation for conditional likelihood confidence intervals, |
|
| 24 | -111x | +
- rval <- c(NA, NA)+ #' therefore the likelihood confidence interval is not available as an option. |
|
| 25 | -111x | +
- mode(rval) <- typeof(x)+ #' * When `vars` contains only responders or non-responders no odds ratio estimation is possible so the returned |
|
| 26 |
- } else {
+ #' values will be `NA`. |
||
| 27 | -1767x | +
- rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))+ #' |
|
| 28 |
- }+ #' @seealso Relevant helper function [h_odds_ratio()]. |
||
| 29 |
-
+ #' |
||
| 30 | -1878x | +
- return(rval)+ #' @name odds_ratio |
|
| 31 |
- }+ #' @order 1 |
||
| 32 |
-
+ NULL |
||
| 33 |
- #' Utility function to create label for confidence interval+ |
||
| 34 |
- #'+ #' @describeIn odds_ratio Statistics function which estimates the odds ratio |
||
| 35 |
- #' @description `r lifecycle::badge("stable")`
+ #' between a treatment and a control. A `variables` list with `arm` and `strata` |
||
| 36 |
- #'+ #' variable names must be passed if a stratified analysis is required. |
||
| 37 |
- #' @inheritParams argument_convention+ #' |
||
| 38 |
- #'+ #' @return |
||
| 39 |
- #' @return A `string`.+ #' * `s_odds_ratio()` returns a named list with the statistics `or_ci` |
||
| 40 |
- #'+ #' (containing `est`, `lcl`, and `ucl`) and `n_tot`. |
||
| 41 |
- #' @export+ #' |
||
| 42 |
- f_conf_level <- function(conf_level) {
+ #' @examples |
||
| 43 | -3968x | +
- assert_proportion_value(conf_level)+ #' # Unstratified analysis. |
|
| 44 | -3966x | +
- paste0(conf_level * 100, "% CI")+ #' s_odds_ratio( |
|
| 45 |
- }+ #' df = subset(dta, grp == "A"), |
||
| 46 |
-
+ #' .var = "rsp", |
||
| 47 |
- #' Utility function to create label for p-value+ #' .ref_group = subset(dta, grp == "B"), |
||
| 48 |
- #'+ #' .in_ref_col = FALSE, |
||
| 49 |
- #' @description `r lifecycle::badge("stable")`
+ #' .df_row = dta |
||
| 50 |
- #'+ #' ) |
||
| 51 |
- #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis.+ #' |
||
| 52 |
- #'+ #' # Stratified analysis. |
||
| 53 |
- #' @return A `string`.+ #' s_odds_ratio( |
||
| 54 |
- #'+ #' df = subset(dta, grp == "A"), |
||
| 55 |
- #' @export+ #' .var = "rsp", |
||
| 56 |
- f_pval <- function(test_mean) {
+ #' .ref_group = subset(dta, grp == "B"), |
||
| 57 | -1139x | +
- checkmate::assert_numeric(test_mean, len = 1)+ #' .in_ref_col = FALSE, |
|
| 58 | -1137x | +
- paste0("p-value (H0: mean = ", test_mean, ")")
+ #' .df_row = dta, |
|
| 59 |
- }+ #' variables = list(arm = "grp", strata = "strata") |
||
| 60 |
-
+ #' ) |
||
| 61 |
- #' Utility function to return a named list of covariate names+ #' |
||
| 62 |
- #'+ #' @export |
||
| 63 |
- #' @param covariates (`character`)\cr a vector that can contain single variable names (such as+ s_odds_ratio <- function(df, |
||
| 64 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ .var, |
||
| 65 |
- #'+ .ref_group, |
||
| 66 |
- #' @return A named `list` of `character` vector.+ .in_ref_col, |
||
| 67 |
- #'+ .df_row, |
||
| 68 |
- #' @keywords internal+ variables = list(arm = NULL, strata = NULL), |
||
| 69 |
- get_covariates <- function(covariates) {
+ conf_level = 0.95, |
||
| 70 | -14x | +
- checkmate::assert_character(covariates)+ groups_list = NULL, |
|
| 71 | -12x | +
- cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*"))))+ method = "exact") {
|
|
| 72 | -12x | +87x |
- stats::setNames(as.list(cov_vars), cov_vars)+ y <- list(or_ci = "", n_tot = "") |
| 73 |
- }+ |
||
| 74 | -+ | 87x |
-
+ if (!.in_ref_col) {
|
| 75 | -+ | 87x |
- #' Replicate entries of a vector if required+ assert_proportion_value(conf_level) |
| 76 | -+ | 87x |
- #'+ assert_df_with_variables(df, list(rsp = .var)) |
| 77 | -+ | 87x |
- #' @description `r lifecycle::badge("stable")`
+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
| 78 |
- #'+ |
||
| 79 | -+ | 87x |
- #' Replicate entries of a vector if required.+ if (is.null(variables$strata)) {
|
| 80 | -+ | 72x |
- #'+ data <- data.frame( |
| 81 | -+ | 72x |
- #' @inheritParams argument_convention+ rsp = c(.ref_group[[.var]], df[[.var]]), |
| 82 | -+ | 72x |
- #' @param n (`integer(1)`)\cr number of entries that are needed.+ grp = factor( |
| 83 | -+ | 72x |
- #'+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
| 84 | -+ | 72x |
- #' @return `x` if it has the required length already or is `NULL`,+ levels = c("ref", "Not-ref")
|
| 85 |
- #' otherwise if it is scalar the replicated version of it with `n` entries.+ ) |
||
| 86 |
- #'+ ) |
||
| 87 | -+ | 72x |
- #' @note This function will fail if `x` is not of length `n` and/or is not a scalar.+ y <- or_glm(data, conf_level = conf_level) |
| 88 |
- #'+ } else {
|
||
| 89 | -+ | 15x |
- #' @export+ assert_df_with_variables(.df_row, c(list(rsp = .var), variables)) |
| 90 | -+ | 15x |
- to_n <- function(x, n) {
+ checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
|
| 91 | -5x | +
- if (is.null(x)) {
+
|
|
| 92 | -1x | +
- NULL+ # The group variable prepared for clogit must be synchronised with combination groups definition. |
|
| 93 | -4x | +15x |
- } else if (length(x) == 1) {
+ if (is.null(groups_list)) {
|
| 94 | -1x | +14x |
- rep(x, n)+ ref_grp <- as.character(unique(.ref_group[[variables$arm]])) |
| 95 | -3x | +14x |
- } else if (length(x) == n) {
+ trt_grp <- as.character(unique(df[[variables$arm]])) |
| 96 | -2x | +14x |
- x+ grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp) |
| 97 |
- } else {
+ } else {
|
||
| 98 | -1x | +
- stop("dimension mismatch")
+ # If more than one level in reference col. |
|
| 99 | -+ | 1x |
- }+ reference <- as.character(unique(.ref_group[[variables$arm]])) |
| 100 | -+ | 1x |
- }+ grp_ref_flag <- vapply( |
| 101 | -+ | 1x |
-
+ X = groups_list, |
| 102 | -+ | 1x |
- #' Check element dimension+ FUN.VALUE = TRUE, |
| 103 | -+ | 1x |
- #'+ FUN = function(x) all(reference %in% x) |
| 104 |
- #' Checks if the elements in `...` have the same dimension.+ ) |
||
| 105 | -+ | 1x |
- #'+ ref_grp <- names(groups_list)[grp_ref_flag] |
| 106 |
- #' @param ... (`data.frame` or `vector`)\cr any data frames or vectors.+ |
||
| 107 |
- #' @param omit_null (`flag`)\cr whether `NULL` elements in `...` should be omitted from the check.+ # If more than one level in treatment col. |
||
| 108 | -+ | 1x |
- #'+ treatment <- as.character(unique(df[[variables$arm]])) |
| 109 | -+ | 1x |
- #' @return A `logical` value.+ grp_trt_flag <- vapply( |
| 110 | -+ | 1x |
- #'+ X = groups_list, |
| 111 | -+ | 1x |
- #' @keywords internal+ FUN.VALUE = TRUE, |
| 112 | -+ | 1x |
- check_same_n <- function(..., omit_null = TRUE) {
+ FUN = function(x) all(treatment %in% x) |
| 113 | -2x | +
- dots <- list(...)+ ) |
|
| 114 | -+ | 1x |
-
+ trt_grp <- names(groups_list)[grp_trt_flag] |
| 115 | -2x | +
- n_list <- Map(+ |
|
| 116 | -2x | +1x |
- function(x, name) {
+ grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp) |
| 117 | -5x | +1x |
- if (is.null(x)) {
+ grp <- combine_levels(grp, levels = treatment, new_level = trt_grp) |
| 118 | -! | +
- if (omit_null) {
+ } |
|
| 119 | -2x | +
- NA_integer_+ |
|
| 120 |
- } else {
+ # The reference level in `grp` must be the same as in the `rtables` column split. |
||
| 121 | -! | +15x |
- stop("arg", name, "is not supposed to be NULL")
+ data <- data.frame( |
| 122 | -+ | 15x |
- }+ rsp = .df_row[[.var]], |
| 123 | -5x | +15x |
- } else if (is.data.frame(x)) {
+ grp = grp, |
| 124 | -! | +15x |
- nrow(x)+ strata = interaction(.df_row[variables$strata]) |
| 125 | -5x | +
- } else if (is.atomic(x)) {
+ ) |
|
| 126 | -5x | +15x |
- length(x)+ y_all <- or_clogit(data, conf_level = conf_level, method = method) |
| 127 | -+ | 15x |
- } else {
+ checkmate::assert_string(trt_grp) |
| 128 | -! | +15x |
- stop("data structure for ", name, "is currently not supported")
+ checkmate::assert_subset(trt_grp, names(y_all$or_ci)) |
| 129 | -+ | 14x |
- }+ y$or_ci <- y_all$or_ci[[trt_grp]] |
| 130 | -+ | 14x |
- },+ y$n_tot <- y_all$n_tot |
| 131 | -2x | +
- dots, names(dots)+ } |
|
| 132 |
- )+ } |
||
| 134 | -2x | +86x |
- n <- stats::na.omit(unlist(n_list))+ if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && method != "approximate") {
|
| 135 | -+ | 1x |
-
+ warning( |
| 136 | -2x | +1x |
- if (length(unique(n)) > 1) {
+ "Unable to compute the odds ratio estimate. Please try re-running the function with ", |
| 137 | -! | +1x |
- sel <- which(n != n[1])+ 'parameter `method` set to "approximate".' |
| 138 | -! | +
- stop("Dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
+ ) |
|
| 141 | -2x | +86x |
- TRUE+ y$or_ci <- formatters::with_label( |
| 142 | -+ | 86x |
- }+ x = y$or_ci, |
| 143 | -+ | 86x |
-
+ label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
|
| 144 |
- #' Utility function to check if a float value is equal to another float value+ ) |
||
| 145 |
- #'+ |
||
| 146 | -+ | 86x |
- #' Uses `.Machine$double.eps` as the tolerance for the comparison.+ y$n_tot <- formatters::with_label( |
| 147 | -+ | 86x |
- #'+ x = y$n_tot, |
| 148 | -+ | 86x |
- #' @param x (`numeric(1)`)\cr a float number.+ label = "Total n" |
| 149 |
- #' @param y (`numeric(1)`)\cr a float number.+ ) |
||
| 150 |
- #'+ |
||
| 151 | -+ | 86x |
- #' @return `TRUE` if identical, otherwise `FALSE`.+ y |
| 152 |
- #'+ } |
||
| 153 |
- #' @keywords internal+ |
||
| 154 |
- .is_equal_float <- function(x, y) {
+ #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`. |
||
| 155 | -2981x | +
- checkmate::assert_number(x)+ #' |
|
| 156 | -2981x | +
- checkmate::assert_number(y)+ #' @return |
|
| 157 |
-
+ #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 158 |
- # Define a tolerance+ #' |
||
| 159 | -2981x | +
- tolerance <- .Machine$double.eps+ #' @examples |
|
| 160 |
-
+ #' a_odds_ratio( |
||
| 161 |
- # Check if x is close enough to y+ #' df = subset(dta, grp == "A"), |
||
| 162 | -2981x | +
- abs(x - y) < tolerance+ #' .var = "rsp", |
|
| 163 |
- }+ #' .ref_group = subset(dta, grp == "B"), |
||
| 164 |
-
+ #' .in_ref_col = FALSE, |
||
| 165 |
- #' Make names without dots+ #' .df_row = dta |
||
| 166 |
- #'+ #' ) |
||
| 167 |
- #' @param nams (`character`)\cr vector of original names.+ #' |
||
| 168 |
- #'+ #' @export |
||
| 169 |
- #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()].+ a_odds_ratio <- make_afun( |
||
| 170 |
- #'+ s_odds_ratio, |
||
| 171 |
- #' @keywords internal+ .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"), |
||
| 172 |
- make_names <- function(nams) {
+ .indent_mods = c(or_ci = 1L) |
||
| 173 | -6x | +
- orig <- make.names(nams)+ ) |
|
| 174 | -6x | +
- gsub(".", "", x = orig, fixed = TRUE)
+
|
|
| 175 |
- }+ #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments |
||
| 176 |
-
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 177 |
- #' Conversion of months to days+ #' |
||
| 178 |
- #'+ #' @return |
||
| 179 |
- #' @description `r lifecycle::badge("stable")`
+ #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions, |
||
| 180 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 181 |
- #' Conversion of months to days. This is an approximative calculation because it+ #' the statistics from `s_odds_ratio()` to the table layout. |
||
| 182 |
- #' considers each month as having an average of 30.4375 days.+ #' |
||
| 183 |
- #'+ #' @examples |
||
| 184 |
- #' @param x (`numeric(1)`)\cr time in months.+ #' set.seed(12) |
||
| 185 |
- #'+ #' dta <- data.frame( |
||
| 186 |
- #' @return A `numeric` vector with the time in days.+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 187 |
- #'+ #' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
|
||
| 188 |
- #' @examples+ #' strata = factor(sample(c("C", "D"), 100, TRUE))
|
||
| 189 |
- #' x <- c(13.25, 8.15, 1, 2.834)+ #' ) |
||
| 190 |
- #' month2day(x)+ #' |
||
| 191 |
- #'+ #' l <- basic_table() %>% |
||
| 192 |
- #' @export+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 193 |
- month2day <- function(x) {
+ #' estimate_odds_ratio(vars = "rsp") |
||
| 194 | -1x | +
- checkmate::assert_numeric(x)+ #' |
|
| 195 | -1x | +
- x * 30.4375+ #' build_table(l, df = dta) |
|
| 196 |
- }+ #' |
||
| 197 |
-
+ #' @export |
||
| 198 |
- #' Conversion of days to months+ #' @order 2 |
||
| 199 |
- #'+ estimate_odds_ratio <- function(lyt, |
||
| 200 |
- #' @param x (`numeric(1)`)\cr time in days.+ vars, |
||
| 201 |
- #'+ variables = list(arm = NULL, strata = NULL), |
||
| 202 |
- #' @return A `numeric` vector with the time in months.+ conf_level = 0.95, |
||
| 203 |
- #'+ groups_list = NULL, |
||
| 204 |
- #' @examples+ na_str = default_na_str(), |
||
| 205 |
- #' x <- c(403, 248, 30, 86)+ nested = TRUE, |
||
| 206 |
- #' day2month(x)+ method = "exact", |
||
| 207 |
- #'+ show_labels = "hidden", |
||
| 208 |
- #' @export+ table_names = vars, |
||
| 209 |
- day2month <- function(x) {
+ var_labels = vars, |
||
| 210 | -19x | +
- checkmate::assert_numeric(x)+ .stats = "or_ci", |
|
| 211 | -19x | +
- x / 30.4375+ .formats = NULL, |
|
| 212 |
- }+ .labels = NULL, |
||
| 213 |
-
+ .indent_mods = NULL) {
|
||
| 214 | -+ | 5x |
- #' Return an empty numeric if all elements are `NA`.+ extra_args <- list(variables = variables, conf_level = conf_level, groups_list = groups_list, method = method) |
| 215 |
- #'+ |
||
| 216 | -+ | 5x |
- #' @param x (`numeric`)\cr vector.+ afun <- make_afun( |
| 217 | -+ | 5x |
- #'+ a_odds_ratio, |
| 218 | -+ | 5x |
- #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`.+ .stats = .stats, |
| 219 | -+ | 5x |
- #'+ .formats = .formats, |
| 220 | -+ | 5x |
- #' @examples+ .labels = .labels, |
| 221 | -+ | 5x |
- #' x <- c(NA, NA, NA)+ .indent_mods = .indent_mods |
| 222 |
- #' # Internal function - empty_vector_if_na+ ) |
||
| 223 |
- #' @keywords internal+ |
||
| 224 | -+ | 5x |
- empty_vector_if_na <- function(x) {
+ analyze( |
| 225 | -1017x | +5x |
- if (all(is.na(x))) {
+ lyt, |
| 226 | -310x | +5x |
- numeric()+ vars, |
| 227 | -+ | 5x |
- } else {
+ afun = afun, |
| 228 | -707x | +5x |
- x+ var_labels = var_labels, |
| 229 | -+ | 5x |
- }+ na_str = na_str, |
| 230 | -+ | 5x |
- }+ nested = nested, |
| 231 | -+ | 5x |
-
+ extra_args = extra_args, |
| 232 | -+ | 5x |
- #' Element-wise combination of two vectors+ show_labels = show_labels, |
| 233 | -+ | 5x |
- #'+ table_names = table_names |
| 234 |
- #' @param x (`vector`)\cr first vector to combine.+ ) |
||
| 235 |
- #' @param y (`vector`)\cr second vector to combine.+ } |
||
| 236 |
- #'+ |
||
| 237 |
- #' @return A `list` where each element combines corresponding elements of `x` and `y`.+ #' Helper functions for odds ratio estimation |
||
| 239 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 240 |
- #' combine_vectors(1:3, 4:6)+ #' |
||
| 241 |
- #'+ #' Functions to calculate odds ratios in [estimate_odds_ratio()]. |
||
| 242 |
- #' @export+ #' |
||
| 243 |
- combine_vectors <- function(x, y) {
+ #' @inheritParams odds_ratio |
||
| 244 | -51x | +
- checkmate::assert_vector(x)+ #' @inheritParams argument_convention |
|
| 245 | -51x | +
- checkmate::assert_vector(y, len = length(x))+ #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally |
|
| 246 |
-
+ #' `strata` for [or_clogit()]. |
||
| 247 | -51x | +
- result <- lapply(as.data.frame(rbind(x, y)), `c`)+ #' |
|
| 248 | -51x | +
- names(result) <- NULL+ #' @return A named `list` of elements `or_ci` and `n_tot`. |
|
| 249 | -51x | +
- result+ #' |
|
| 250 |
- }+ #' @seealso [odds_ratio] |
||
| 251 |
-
+ #' |
||
| 252 |
- #' Extract elements by name+ #' @name h_odds_ratio |
||
| 253 |
- #'+ NULL |
||
| 254 |
- #' This utility function extracts elements from a vector `x` by `names`.+ |
||
| 255 |
- #' Differences to the standard `[` function are:+ #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be |
||
| 256 |
- #'+ #' exactly 2 groups in `data` as specified by the `grp` variable. |
||
| 257 |
- #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).+ #' |
||
| 258 |
- #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those+ #' @examples |
||
| 259 |
- #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.+ #' # Data with 2 groups. |
||
| 260 |
- #'+ #' data <- data.frame( |
||
| 261 |
- #' @param x (named `vector`)\cr where to extract named elements from.+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)), |
||
| 262 |
- #' @param names (`character`)\cr vector of names to extract.+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)], |
||
| 263 |
- #'+ #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)], |
||
| 264 |
- #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`.+ #' stringsAsFactors = TRUE |
||
| 265 |
- #'+ #' ) |
||
| 266 |
- #' @keywords internal+ #' |
||
| 267 |
- extract_by_name <- function(x, names) {
+ #' # Odds ratio based on glm. |
||
| 268 | -3x | +
- if (is.null(x)) {
+ #' or_glm(data, conf_level = 0.95) |
|
| 269 | -1x | +
- return(NULL)+ #' |
|
| 270 |
- }+ #' @export |
||
| 271 | -2x | +
- checkmate::assert_named(x)+ or_glm <- function(data, conf_level) {
|
|
| 272 | -2x | +77x |
- checkmate::assert_character(names)+ checkmate::assert_logical(data$rsp) |
| 273 | -2x | +77x |
- which_extract <- intersect(names(x), names)+ assert_proportion_value(conf_level) |
| 274 | -2x | +77x |
- if (length(which_extract) > 0) {
+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp")) |
| 275 | -1x | +77x |
- x[which_extract]+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
| 276 |
- } else {
+
|
||
| 277 | -1x | +77x |
- NULL+ data$grp <- as_factor_keep_attributes(data$grp) |
| 278 | -+ | 77x |
- }+ assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2) |
| 279 | -+ | 77x |
- }+ formula <- stats::as.formula("rsp ~ grp")
|
| 280 | -+ | 77x |
-
+ model_fit <- stats::glm( |
| 281 | -+ | 77x |
- #' Labels for adverse event baskets+ formula = formula, data = data, |
| 282 | -+ | 77x |
- #'+ family = stats::binomial(link = "logit") |
| 283 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 284 |
- #'+ |
||
| 285 |
- #' @param aesi (`character`)\cr vector with standardized MedDRA query name (e.g. `SMQxxNAM`) or customized query+ # Note that here we need to discard the intercept. |
||
| 286 | -+ | 77x |
- #' name (e.g. `CQxxNAM`).+ or <- exp(stats::coef(model_fit)[-1]) |
| 287 | -+ | 77x |
- #' @param scope (`character`)\cr vector with scope of query (e.g. `SMQxxSC`).+ or_ci <- exp( |
| 288 | -+ | 77x |
- #'+ stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE] |
| 289 |
- #' @return A `string` with the standard label for the AE basket.+ ) |
||
| 290 |
- #'+ |
||
| 291 | -+ | 77x |
- #' @examples+ values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
|
| 292 | -+ | 77x |
- #' adae <- tern_ex_adae+ n_tot <- stats::setNames(nrow(model_fit$model), "n_tot") |
| 293 |
- #'+ |
||
| 294 | -+ | 77x |
- #' # Standardized query label includes scope.+ list(or_ci = values, n_tot = n_tot) |
| 295 |
- #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)+ } |
||
| 296 |
- #'+ |
||
| 297 |
- #' # Customized query label.+ #' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for |
||
| 298 |
- #' aesi_label(adae$CQ01NAM)+ #' the whole data set including all groups, since the results are not the same as when doing |
||
| 299 |
- #'+ #' pairwise comparisons between the groups. |
||
| 300 |
- #' @export+ #' |
||
| 301 |
- aesi_label <- function(aesi, scope = NULL) {
+ #' @examples |
||
| 302 | -4x | +
- checkmate::assert_character(aesi)+ #' # Data with 3 groups. |
|
| 303 | -4x | +
- checkmate::assert_character(scope, null.ok = TRUE)+ #' data <- data.frame( |
|
| 304 | -4x | +
- aesi_label <- obj_label(aesi)+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)), |
|
| 305 | -4x | +
- aesi <- sas_na(aesi)+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)], |
|
| 306 | -4x | +
- aesi <- unique(aesi)[!is.na(unique(aesi))]+ #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)], |
|
| 307 |
-
+ #' stringsAsFactors = TRUE |
||
| 308 | -4x | +
- lbl <- if (length(aesi) == 1 && !is.null(scope)) {
+ #' ) |
|
| 309 | -1x | +
- scope <- sas_na(scope)+ #' |
|
| 310 | -1x | +
- scope <- unique(scope)[!is.na(unique(scope))]+ #' # Odds ratio based on stratified estimation by conditional logistic regression. |
|
| 311 | -1x | +
- checkmate::assert_string(scope)+ #' or_clogit(data, conf_level = 0.95) |
|
| 312 | -1x | +
- paste0(aesi, " (", scope, ")")
+ #' |
|
| 313 | -4x | +
- } else if (length(aesi) == 1 && is.null(scope)) {
+ #' @export |
|
| 314 | -1x | +
- aesi+ or_clogit <- function(data, conf_level, method = "exact") {
|
|
| 315 | -+ | 19x |
- } else {
+ checkmate::assert_logical(data$rsp) |
| 316 | -2x | +19x |
- aesi_label+ assert_proportion_value(conf_level) |
| 317 | -+ | 19x |
- }+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata")) |
| 318 | -+ | 19x |
-
+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
| 319 | -4x | +19x |
- lbl+ checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
|
| 320 | -+ | 19x |
- }+ checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
|
| 322 | -+ | 19x |
- #' Indicate study arm variable in formula+ data$grp <- as_factor_keep_attributes(data$grp) |
| 323 | -+ | 19x |
- #'+ data$strata <- as_factor_keep_attributes(data$strata) |
| 324 |
- #' We use `study_arm` to indicate the study arm variable in `tern` formulas.+ |
||
| 325 |
- #'+ # Deviation from convention: `survival::strata` must be simply `strata`. |
||
| 326 | -+ | 19x |
- #' @param x arm information+ formula <- stats::as.formula("rsp ~ grp + strata(strata)")
|
| 327 | -+ | 19x |
- #'+ model_fit <- clogit_with_tryCatch(formula = formula, data = data, method = method) |
| 328 |
- #' @return `x`+ |
||
| 329 |
- #'+ # Create a list with one set of OR estimates and CI per coefficient, i.e. |
||
| 330 |
- #' @keywords internal+ # comparison of one group vs. the reference group. |
||
| 331 | -+ | 19x |
- study_arm <- function(x) {
+ coef_est <- stats::coef(model_fit) |
| 332 | -! | +19x |
- structure(x, varname = deparse(substitute(x)))+ ci_est <- stats::confint(model_fit, level = conf_level) |
| 333 | -+ | 19x |
- }+ or_ci <- list() |
| 334 | -+ | 19x |
-
+ for (coef_name in names(coef_est)) {
|
| 335 | -+ | 21x |
- #' Smooth function with optional grouping+ grp_name <- gsub("^grp", "", x = coef_name)
|
| 336 | -+ | 21x |
- #'+ or_ci[[grp_name]] <- stats::setNames( |
| 337 | -+ | 21x |
- #' @description `r lifecycle::badge("stable")`
+ object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), |
| 338 | -+ | 21x |
- #'+ nm = c("est", "lcl", "ucl")
|
| 339 |
- #' This produces `loess` smoothed estimates of `y` with Student confidence intervals.+ ) |
||
| 340 |
- #'+ } |
||
| 341 | -+ | 19x |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n)) |
| 342 |
- #' @param x (`string`)\cr x column name.+ } |
| 343 | +1 |
- #' @param y (`string`)\cr y column name.+ #' Count occurrences |
||
| 344 | +2 |
- #' @param groups (`character` or `NULL`)\cr vector with optional grouping variables names.+ #' |
||
| 345 | +3 |
- #' @param level (`proportion`)\cr level of confidence interval to use (0.95 by default).+ #' @description `r lifecycle::badge("stable")`
|
||
| 346 | +4 |
#' |
||
| 347 | +5 |
- #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and+ #' The analyze function [count_occurrences()] creates a layout element to calculate occurrence counts for patients. |
||
| 348 | +6 |
- #' optional `groups` variables formatted as `factor` type.+ #' |
||
| 349 | +7 |
- #'+ #' This function analyzes the variable(s) supplied to `vars` and returns a table of occurrence counts for |
||
| 350 | +8 |
- #' @export+ #' each unique value (or level) of the variable(s). This variable (or variables) must be |
||
| 351 | +9 |
- get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
- |
- ||
| 352 | -5x | -
- checkmate::assert_data_frame(df)- |
- ||
| 353 | -5x | -
- df_cols <- colnames(df)- |
- ||
| 354 | -5x | -
- checkmate::assert_string(x)+ #' non-numeric. The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`). |
||
| 355 | -5x | +|||
| 10 | +
- checkmate::assert_subset(x, df_cols)+ #' |
|||
| 356 | -5x | +|||
| 11 | +
- checkmate::assert_numeric(df[[x]])+ #' If there are multiple occurrences of the same value recorded for a patient, the value is only counted once. |
|||
| 357 | -5x | +|||
| 12 | +
- checkmate::assert_string(y)+ #' |
|||
| 358 | -5x | +|||
| 13 | +
- checkmate::assert_subset(y, df_cols)+ #' The summarize function [summarize_occurrences()] performs the same function as [count_occurrences()] except it |
|||
| 359 | -5x | +|||
| 14 | +
- checkmate::assert_numeric(df[[y]])+ #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of |
|||
| 360 | +15 |
-
+ #' the latest row split or the root of the table if no row splits have occurred. |
||
| 361 | -5x | +|||
| 16 | +
- if (!is.null(groups)) {
+ #' |
|||
| 362 | -4x | +|||
| 17 | +
- checkmate::assert_character(groups)+ #' @inheritParams argument_convention |
|||
| 363 | -4x | +|||
| 18 | +
- checkmate::assert_subset(groups, df_cols)+ #' @param drop (`flag`)\cr whether non-appearing occurrence levels should be dropped from the resulting table. |
|||
| 364 | +19 |
- }+ #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically. |
||
| 365 | +20 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 366 | -5x | +|||
| 21 | +
- smooths <- function(x, y) {
+ #' |
|||
| 367 | -18x | +|||
| 22 | +
- stats::predict(stats::loess(y ~ x), se = TRUE)+ #' Options are: ``r shQuote(get_stats("count_occurrences"))``
|
|||
| 368 | +23 |
- }+ #' |
||
| 369 | +24 |
-
+ #' @note By default, occurrences which don't appear in a given row split are dropped from the table and |
||
| 370 | -5x | +|||
| 25 | +
- if (!is.null(groups)) {
+ #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout |
|||
| 371 | -4x | +|||
| 26 | +
- cc <- stats::complete.cases(df[c(x, y, groups)])+ #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would |
|||
| 372 | -4x | +|||
| 27 | +
- df_c <- df[cc, c(x, y, groups)]+ #' like to show all occurrences. |
|||
| 373 | -4x | +|||
| 28 | +
- df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
+ #' |
|||
| 374 | -4x | +|||
| 29 | +
- df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))+ #' @examples |
|||
| 375 | +30 |
-
+ #' library(dplyr) |
||
| 376 | -4x | +|||
| 31 | +
- df_smooth_raw <-+ #' df <- data.frame( |
|||
| 377 | -4x | +|||
| 32 | +
- by(df_c_ordered, df_c_g, function(d) {
+ #' USUBJID = as.character(c( |
|||
| 378 | -17x | +|||
| 33 | +
- plx <- smooths(d[[x]], d[[y]])+ #' 1, 1, 2, 4, 4, 4, |
|||
| 379 | -17x | +|||
| 34 | +
- data.frame(+ #' 6, 6, 6, 7, 7, 8 |
|||
| 380 | -17x | +|||
| 35 | +
- x = d[[x]],+ #' )), |
|||
| 381 | -17x | +|||
| 36 | +
- y = plx$fit,+ #' MHDECOD = c( |
|||
| 382 | -17x | +|||
| 37 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3", |
|||
| 383 | -17x | +|||
| 38 | +
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4" |
|||
| 384 | +39 |
- )+ #' ), |
||
| 385 | +40 |
- })+ #' ARM = rep(c("A", "B"), each = 6),
|
||
| 386 | +41 |
-
+ #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
|
||
| 387 | -4x | +|||
| 42 | +
- df_smooth <- do.call(rbind, df_smooth_raw)+ #' ) |
|||
| 388 | -4x | +|||
| 43 | +
- df_smooth[groups] <- df_c_g+ #' df_adsl <- df %>% |
|||
| 389 | +44 |
-
+ #' select(USUBJID, ARM) %>% |
||
| 390 | -4x | +|||
| 45 | +
- df_smooth+ #' unique() |
|||
| 391 | +46 |
- } else {
+ #' |
||
| 392 | -1x | +|||
| 47 | +
- cc <- stats::complete.cases(df[c(x, y)])+ #' @name count_occurrences |
|||
| 393 | -1x | +|||
| 48 | +
- df_c <- df[cc, ]+ #' @order 1 |
|||
| 394 | -1x | +|||
| 49 | +
- plx <- smooths(df_c[[x]], df_c[[y]])+ NULL |
|||
| 395 | +50 | |||
| 396 | -1x | -
- df_smooth <- data.frame(- |
- ||
| 397 | -1x | +|||
| 51 | +
- x = df_c[[x]],+ #' @describeIn count_occurrences Statistics function which counts number of patients that report an |
|||
| 398 | -1x | +|||
| 52 | +
- y = plx$fit,+ #' occurrence. |
|||
| 399 | -1x | +|||
| 53 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ #' |
|||
| 400 | -1x | +|||
| 54 | +
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ #' @param denom (`string`)\cr choice of denominator for proportion. Options are: |
|||
| 401 | +55 |
- )+ #' * `N_col`: total number of patients in this column across rows. |
||
| 402 | +56 |
-
+ #' * `n`: number of patients with any occurrences. |
||
| 403 | -1x | +|||
| 57 | +
- df_smooth+ #' * `N_row`: total number of patients in this row across columns. |
|||
| 404 | +58 |
- }+ #' |
||
| 405 | +59 |
- }+ #' @return |
||
| 406 | +60 |
-
+ #' * `s_count_occurrences()` returns a list with: |
||
| 407 | +61 |
- #' Number of available (non-missing entries) in a vector+ #' * `count`: list of counts with one element per occurrence. |
||
| 408 | +62 |
- #'+ #' * `count_fraction`: list of counts and fractions with one element per occurrence. |
||
| 409 | +63 |
- #' Small utility function for better readability.+ #' * `fraction`: list of numerators and denominators with one element per occurrence. |
||
| 410 | +64 |
#' |
||
| 411 | +65 |
- #' @param x (`vector`)\cr vector in which to count non-missing values.+ #' @examples |
||
| 412 | +66 |
- #'+ #' # Count unique occurrences per subject. |
||
| 413 | +67 |
- #' @return Number of non-missing values.+ #' s_count_occurrences( |
||
| 414 | +68 |
- #'+ #' df, |
||
| 415 | +69 |
- #' @keywords internal+ #' .N_col = 4L, |
||
| 416 | +70 |
- n_available <- function(x) {
+ #' .N_row = 4L, |
||
| 417 | -355x | +|||
| 71 | +
- sum(!is.na(x))+ #' .df_row = df, |
|||
| 418 | +72 |
- }+ #' .var = "MHDECOD", |
||
| 419 | +73 |
-
+ #' id = "USUBJID" |
||
| 420 | +74 |
- #' Reapply variable labels+ #' ) |
||
| 421 | +75 |
#' |
||
| 422 | +76 |
- #' This is a helper function that is used in tests.+ #' @export |
||
| 423 | +77 |
- #'+ s_count_occurrences <- function(df, |
||
| 424 | +78 |
- #' @param x (`vector`)\cr vector of elements that needs new labels.+ denom = c("N_col", "n", "N_row"),
|
||
| 425 | +79 |
- #' @param varlabels (`character`)\cr vector of labels for `x`.+ .N_col, # nolint |
||
| 426 | +80 |
- #' @param ... further parameters to be added to the list.+ .N_row, # nolint |
||
| 427 | +81 |
- #'+ .df_row, |
||
| 428 | +82 |
- #' @return `x` with variable labels reapplied.+ drop = TRUE, |
||
| 429 | +83 |
- #'+ .var = "MHDECOD", |
||
| 430 | +84 |
- #' @export+ id = "USUBJID") {
|
||
| 431 | -+ | |||
| 85 | +126x |
- reapply_varlabels <- function(x, varlabels, ...) {
+ checkmate::assert_flag(drop) |
||
| 432 | -11x | +86 | +126x |
- named_labels <- c(as.list(varlabels), list(...))+ assert_df_with_variables(df, list(range = .var, id = id)) |
| 433 | -11x | +87 | +126x |
- formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)+ checkmate::assert_count(.N_col) |
| 434 | -11x | +88 | +126x |
- x+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 435 | -+ | |||
| 89 | +126x |
- }+ checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
|
||
| 436 | +90 | |||
| 437 | -+ | |||
| 91 | +126x |
- # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show+ occurrences <- if (drop) {
|
||
| 438 | +92 |
- clogit_with_tryCatch <- function(formula, data, ...) { # nolint
+ # Note that we don't try to preserve original level order here since a) that would required |
||
| 439 | -33x | +|||
| 93 | +
- tryCatch(+ # more time to look up in large original levels and b) that would fail for character input variable. |
|||
| 440 | -33x | +94 | +115x |
- survival::clogit(formula = formula, data = data, ...),+ occurrence_levels <- sort(unique(.df_row[[.var]])) |
| 441 | -33x | +95 | +115x |
- error = function(e) stop("model not built successfully with survival::clogit")
+ if (length(occurrence_levels) == 0) {
|
| 442 | -+ | |||
| 96 | +1x |
- )+ stop( |
||
| 443 | -+ | |||
| 97 | +1x |
- }+ "no empty `.df_row` input allowed when `drop = TRUE`,", |
| 1 | -+ | |||
| 98 | +1x |
- #' Helper functions for incidence rate+ " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls" |
||
| 2 | +99 |
- #'+ ) |
||
| 3 | +100 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | -+ | |||
| 101 | +114x |
- #'+ factor(df[[.var]], levels = occurrence_levels) |
||
| 5 | +102 |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ } else {
|
||
| 6 | -+ | |||
| 103 | +11x |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ df[[.var]] |
||
| 7 | +104 |
- #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.+ } |
||
| 8 | -+ | |||
| 105 | +125x |
- #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ ids <- factor(df[[id]]) |
||
| 9 | -+ | |||
| 106 | +125x |
- #' for confidence interval type.+ denom <- match.arg(denom) %>% |
||
| 10 | -+ | |||
| 107 | +125x |
- #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default)+ switch( |
||
| 11 | -+ | |||
| 108 | +125x |
- #' indicating time unit for data input.+ n = nlevels(ids), |
||
| 12 | -+ | |||
| 109 | +125x |
- #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years).+ N_row = .N_row, |
||
| 13 | -+ | |||
| 110 | +125x |
- #' @param person_years (`numeric(1)`)\cr total person-years at risk.+ N_col = .N_col |
||
| 14 | +111 |
- #' @param alpha (`numeric(1)`)\cr two-sided alpha-level for confidence interval.+ ) |
||
| 15 | -+ | |||
| 112 | +125x |
- #' @param n_events (`integer(1)`)\cr number of events observed.+ has_occurrence_per_id <- table(occurrences, ids) > 0 |
||
| 16 | -+ | |||
| 113 | +125x |
- #'+ n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id)) |
||
| 17 | -+ | |||
| 114 | +125x |
- #' @return Estimated incidence rate, `rate`, and associated confidence interval, `rate_ci`.+ list( |
||
| 18 | -+ | |||
| 115 | +125x |
- #'+ count = n_ids_per_occurrence, |
||
| 19 | -+ | |||
| 116 | +125x |
- #' @seealso [incidence_rate]+ count_fraction = lapply( |
||
| 20 | -+ | |||
| 117 | +125x |
- #'+ n_ids_per_occurrence, |
||
| 21 | -+ | |||
| 118 | +125x |
- #' @name h_incidence_rate+ function(i, denom) {
|
||
| 22 | -+ | |||
| 119 | +514x |
- NULL+ if (i == 0 && denom == 0) {
|
||
| 23 | -+ | |||
| 120 | +! |
-
+ c(0, 0) |
||
| 24 | +121 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ } else {
|
||
| 25 | -+ | |||
| 122 | +514x |
- #' associated confidence interval.+ c(i, i / denom) |
||
| 26 | +123 |
- #'+ } |
||
| 27 | +124 |
- #' @keywords internal+ }, |
||
| 28 | -+ | |||
| 125 | +125x |
- h_incidence_rate <- function(person_years,+ denom = denom |
||
| 29 | +126 |
- n_events,+ ), |
||
| 30 | -+ | |||
| 127 | +125x |
- control = control_incidence_rate()) {
+ fraction = lapply( |
||
| 31 | -18x | +128 | +125x |
- alpha <- 1 - control$conf_level+ n_ids_per_occurrence, |
| 32 | -18x | +129 | +125x |
- est <- switch(control$conf_type,+ function(i, denom) c("num" = i, "denom" = denom),
|
| 33 | -18x | +130 | +125x |
- normal = h_incidence_rate_normal(person_years, n_events, alpha),+ denom = denom |
| 34 | -18x | +|||
| 131 | +
- normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),+ ) |
|||
| 35 | -18x | +|||
| 132 | +
- exact = h_incidence_rate_exact(person_years, n_events, alpha),+ ) |
|||
| 36 | -18x | +|||
| 133 | +
- byar = h_incidence_rate_byar(person_years, n_events, alpha)+ } |
|||
| 37 | +134 |
- )+ |
||
| 38 | +135 |
-
+ #' @describeIn count_occurrences Formatted analysis function which is used as `afun` |
||
| 39 | -18x | +|||
| 136 | +
- num_pt_year <- control$num_pt_year+ #' in `count_occurrences()`. |
|||
| 40 | -18x | +|||
| 137 | +
- list(+ #' |
|||
| 41 | -18x | +|||
| 138 | +
- rate = est$rate * num_pt_year,+ #' @return |
|||
| 42 | -18x | +|||
| 139 | +
- rate_ci = est$rate_ci * num_pt_year+ #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 43 | +140 |
- )+ #' |
||
| 44 | +141 |
- }+ #' @examples |
||
| 45 | +142 |
-
+ #' a_count_occurrences( |
||
| 46 | +143 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' df, |
||
| 47 | +144 |
- #' associated confidence interval based on the normal approximation for the+ #' .N_col = 4L, |
||
| 48 | +145 |
- #' incidence rate. Unit is one person-year.+ #' .df_row = df, |
||
| 49 | +146 |
- #'+ #' .var = "MHDECOD", |
||
| 50 | +147 |
- #' @examples+ #' id = "USUBJID" |
||
| 51 | +148 |
- #' h_incidence_rate_normal(200, 2)+ #' ) |
||
| 52 | +149 |
#' |
||
| 53 | +150 |
#' @export |
||
| 54 | +151 |
- h_incidence_rate_normal <- function(person_years,+ a_count_occurrences <- function(df, |
||
| 55 | +152 |
- n_events,+ labelstr = "", |
||
| 56 | +153 |
- alpha = 0.05) {
+ id = "USUBJID", |
||
| 57 | -14x | +|||
| 154 | +
- checkmate::assert_number(person_years)+ denom = c("N_col", "n", "N_row"),
|
|||
| 58 | -14x | +|||
| 155 | +
- checkmate::assert_number(n_events)+ drop = TRUE, |
|||
| 59 | -14x | +|||
| 156 | +
- assert_proportion_value(alpha)+ .N_col, # nolint |
|||
| 60 | +157 |
-
+ .N_row, # nolint |
||
| 61 | -14x | +|||
| 158 | +
- est <- n_events / person_years+ .var = NULL, |
|||
| 62 | -14x | +|||
| 159 | +
- se <- sqrt(est / person_years)- |
- |||
| 63 | -14x | -
- ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se- |
- ||
| 64 | -- | - - | -||
| 65 | -14x | -
- list(rate = est, rate_ci = ci)- |
- ||
| 66 | -- |
- }+ .df_row = NULL, |
||
| 67 | +160 |
-
+ .stats = NULL, |
||
| 68 | +161 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ .formats = NULL, |
||
| 69 | +162 |
- #' associated confidence interval based on the normal approximation for the+ .labels = NULL, |
||
| 70 | +163 |
- #' logarithm of the incidence rate. Unit is one person-year.+ .indent_mods = NULL, |
||
| 71 | +164 |
- #'+ na_str = default_na_str()) {
|
||
| 72 | -+ | |||
| 165 | +85x |
- #' @examples+ denom <- match.arg(denom) |
||
| 73 | -+ | |||
| 166 | +85x |
- #' h_incidence_rate_normal_log(200, 2)+ x_stats <- s_count_occurrences( |
||
| 74 | -+ | |||
| 167 | +85x |
- #'+ df = df, denom = denom, .N_col = .N_col, .N_row = .N_row, .df_row = .df_row, drop = drop, .var = .var, id = id |
||
| 75 | +168 |
- #' @export+ ) |
||
| 76 | -+ | |||
| 169 | +85x |
- h_incidence_rate_normal_log <- function(person_years,+ if (is.null(unlist(x_stats))) {
|
||
| 77 | -+ | |||
| 170 | +3x |
- n_events,+ return(NULL) |
||
| 78 | +171 |
- alpha = 0.05) {
- |
- ||
| 79 | -6x | -
- checkmate::assert_number(person_years)- |
- ||
| 80 | -6x | -
- checkmate::assert_number(n_events)+ } |
||
| 81 | -6x | +172 | +82x |
- assert_proportion_value(alpha)+ x_lvls <- names(x_stats[[1]]) |
| 82 | +173 | |||
| 83 | -6x | +|||
| 174 | +
- rate_est <- n_events / person_years+ # Fill in with formatting defaults if needed |
|||
| 84 | -6x | +175 | +82x |
- rate_se <- sqrt(rate_est / person_years)+ .stats <- get_stats("count_occurrences", stats_in = .stats)
|
| 85 | -6x | +176 | +82x |
- lrate_est <- log(rate_est)+ .formats <- get_formats_from_stats(.stats, .formats) |
| 86 | -6x | +177 | +82x |
- lrate_se <- rate_se / rate_est+ .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls) |
| 87 | -6x | +178 | +82x |
- ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls) |
| 88 | +179 | |||
| 89 | -6x | +180 | +81x |
- list(rate = rate_est, rate_ci = ci)+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
| 90 | -+ | |||
| 181 | +82x |
- }+ x_stats <- x_stats[.stats] |
||
| 91 | +182 | |||
| 92 | -- |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and- |
- ||
| 93 | -- |
- #' associated exact confidence interval. Unit is one person-year.- |
- ||
| 94 | +183 |
- #'+ # Ungroup statistics with values for each level of x |
||
| 95 | -+ | |||
| 184 | +82x |
- #' @examples+ x_ungrp <- ungroup_stats(x_stats, .formats, list(), list()) |
||
| 96 | -+ | |||
| 185 | +82x |
- #' h_incidence_rate_exact(200, 2)+ x_stats <- x_ungrp[["x"]] |
||
| 97 | -+ | |||
| 186 | +82x |
- #'+ .formats <- x_ungrp[[".formats"]] |
||
| 98 | +187 |
- #' @export+ |
||
| 99 | +188 |
- h_incidence_rate_exact <- function(person_years,+ # Auto format handling |
||
| 100 | -+ | |||
| 189 | +82x |
- n_events,+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 101 | +190 |
- alpha = 0.05) {
+
|
||
| 102 | -1x | +191 | +82x |
- checkmate::assert_number(person_years)+ in_rows( |
| 103 | -1x | +192 | +82x |
- checkmate::assert_number(n_events)+ .list = x_stats, |
| 104 | -1x | +193 | +82x |
- assert_proportion_value(alpha)+ .formats = .formats, |
| 105 | -+ | |||
| 194 | +82x |
-
+ .names = .labels, |
||
| 106 | -1x | +195 | +82x |
- est <- n_events / person_years+ .labels = .labels, |
| 107 | -1x | +196 | +82x |
- lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)+ .indent_mods = .indent_mods, |
| 108 | -1x | +197 | +82x |
- ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)+ .format_na_strs = na_str |
| 109 | +198 | - - | -||
| 110 | -1x | -
- list(rate = est, rate_ci = c(lcl, ucl))+ ) |
||
| 111 | +199 |
} |
||
| 112 | +200 | |||
| 113 | +201 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments |
||
| 114 | +202 |
- #' associated Byar's confidence interval. Unit is one person-year.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 115 | +203 |
#' |
||
| 116 | +204 |
- #' @examples+ #' @return |
||
| 117 | +205 |
- #' h_incidence_rate_byar(200, 2)+ #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions, |
||
| 118 | +206 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 119 | +207 |
- #' @export+ #' the statistics from `s_count_occurrences()` to the table layout. |
||
| 120 | +208 |
- h_incidence_rate_byar <- function(person_years,+ #' |
||
| 121 | +209 |
- n_events,+ #' @examples |
||
| 122 | +210 |
- alpha = 0.05) {
+ #' # Create table layout |
||
| 123 | -1x | +|||
| 211 | +
- checkmate::assert_number(person_years)+ #' lyt <- basic_table() %>% |
|||
| 124 | -1x | +|||
| 212 | +
- checkmate::assert_number(n_events)+ #' split_cols_by("ARM") %>%
|
|||
| 125 | -1x | +|||
| 213 | +
- assert_proportion_value(alpha)+ #' add_colcounts() %>% |
|||
| 126 | +214 |
-
+ #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
|
||
| 127 | -1x | +|||
| 215 | +
- est <- n_events / person_years+ #' |
|||
| 128 | -1x | +|||
| 216 | +
- seg_1 <- n_events + 0.5+ #' # Apply table layout to data and produce `rtable` object |
|||
| 129 | -1x | +|||
| 217 | +
- seg_2 <- 1 - 1 / (9 * (n_events + 0.5))+ #' tbl <- lyt %>% |
|||
| 130 | -1x | +|||
| 218 | +
- seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3+ #' build_table(df, alt_counts_df = df_adsl) %>% |
|||
| 131 | -1x | +|||
| 219 | +
- lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years+ #' prune_table() |
|||
| 132 | -1x | +|||
| 220 | +
- ucl <- seg_1 * ((seg_2 + seg_3)^3) / person_years+ #' |
|||
| 133 | +221 |
-
+ #' tbl |
||
| 134 | -1x | +|||
| 222 | +
- list(rate = est, rate_ci = c(lcl, ucl))+ #' |
|||
| 135 | +223 |
- }+ #' @export |
| 1 | +224 |
- #' Compare variables between groups+ #' @order 2 |
||
| 2 | +225 |
- #'+ count_occurrences <- function(lyt, |
||
| 3 | +226 |
- #' @description `r lifecycle::badge("stable")`
+ vars, |
||
| 4 | +227 |
- #'+ id = "USUBJID", |
||
| 5 | +228 |
- #' The analyze function [compare_vars()] creates a layout element to summarize and compare one or more variables, using+ drop = TRUE, |
||
| 6 | +229 |
- #' the S3 generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics+ var_labels = vars, |
||
| 7 | +230 |
- #' for numeric variables can be viewed by running `get_stats("analyze_vars_numeric", add_pval = TRUE)` and for
+ show_labels = "hidden", |
||
| 8 | +231 |
- #' non-numeric variables by running `get_stats("analyze_vars_counts", add_pval = TRUE)`. Use the `.stats` parameter to
+ riskdiff = FALSE, |
||
| 9 | +232 |
- #' specify the statistics to include in your output summary table.+ na_str = default_na_str(), |
||
| 10 | +233 |
- #'+ nested = TRUE, |
||
| 11 | +234 |
- #' Prior to using this function in your table layout you must use [rtables::split_cols_by()] to create a column+ ..., |
||
| 12 | +235 |
- #' split on the variable to be used in comparisons, and specify a reference group via the `ref_group` parameter.+ table_names = vars, |
||
| 13 | +236 |
- #' Comparisons can be performed for each group (column) against the specified reference group by including the p-value+ .stats = "count_fraction_fixed_dp", |
||
| 14 | +237 |
- #' statistic.+ .formats = NULL, |
||
| 15 | +238 |
- #'+ .labels = NULL, |
||
| 16 | +239 |
- #' @inheritParams argument_convention+ .indent_mods = NULL) {
|
||
| 17 | -+ | |||
| 240 | +9x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ checkmate::assert_flag(riskdiff) |
||
| 18 | +241 |
- #'+ |
||
| 19 | -+ | |||
| 242 | +9x |
- #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric", add_pval = TRUE))``
+ extra_args <- list( |
||
| 20 | -+ | |||
| 243 | +9x |
- #'+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
||
| 21 | +244 |
- #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts", add_pval = TRUE))``
+ ) |
||
| 22 | -+ | |||
| 245 | +9x |
- #'+ s_args <- list(id = id, drop = drop, ...) |
||
| 23 | +246 |
- #' @note+ |
||
| 24 | -+ | |||
| 247 | +9x |
- #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions+ if (isFALSE(riskdiff)) {
|
||
| 25 | -+ | |||
| 248 | +6x |
- #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would+ extra_args <- c(extra_args, s_args) |
||
| 26 | +249 |
- #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted+ } else {
|
||
| 27 | -+ | |||
| 250 | +3x |
- #' for as explicit factor levels.+ extra_args <- c( |
||
| 28 | -+ | |||
| 251 | +3x |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ extra_args, |
||
| 29 | -+ | |||
| 252 | +3x |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ list( |
||
| 30 | -+ | |||
| 253 | +3x |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ afun = list("s_count_occurrences" = a_count_occurrences),
|
||
| 31 | -+ | |||
| 254 | +3x |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ s_args = s_args |
||
| 32 | +255 |
- #' * For character variables, automatic conversion to factor does not guarantee that the table+ ) |
||
| 33 | +256 |
- #' will be generated correctly. In particular for sparse tables this very likely can fail.+ ) |
||
| 34 | +257 |
- #' Therefore it is always better to manually convert character variables to factors during pre-processing.+ } |
||
| 35 | +258 |
- #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison+ |
||
| 36 | -+ | |||
| 259 | +9x |
- #' is well defined.+ analyze( |
||
| 37 | -+ | |||
| 260 | +9x |
- #'+ lyt = lyt, |
||
| 38 | -+ | |||
| 261 | +9x |
- #' @seealso [s_summary()] which is used internally to compute a summary within `s_compare()`, and [a_summary()]+ vars = vars, |
||
| 39 | -+ | |||
| 262 | +9x |
- #' which is used (with `compare = TRUE`) as the analysis function for `compare_vars()`.+ afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff), |
||
| 40 | -+ | |||
| 263 | +9x |
- #'+ var_labels = var_labels, |
||
| 41 | -+ | |||
| 264 | +9x |
- #' @name compare_variables+ show_labels = show_labels, |
||
| 42 | -+ | |||
| 265 | +9x |
- #' @include analyze_variables.R+ table_names = table_names, |
||
| 43 | -+ | |||
| 266 | +9x |
- #' @order 1+ na_str = na_str, |
||
| 44 | -+ | |||
| 267 | +9x |
- NULL+ nested = nested,+ |
+ ||
| 268 | +9x | +
+ extra_args = extra_args |
||
| 45 | +269 |
-
+ ) |
||
| 46 | +270 |
- #' @describeIn compare_variables S3 generic function to produce a comparison summary.+ } |
||
| 47 | +271 |
- #'+ |
||
| 48 | +272 |
- #' @return+ #' @describeIn count_occurrences Layout-creating function which can take content function arguments |
||
| 49 | +273 |
- #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values.+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 50 | +274 |
#' |
||
| 51 | +275 |
- #' @export+ #' @return |
||
| 52 | +276 |
- s_compare <- function(x,+ #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions, |
||
| 53 | +277 |
- .ref_group,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 54 | +278 |
- .in_ref_col,+ #' containing the statistics from `s_count_occurrences()` to the table layout. |
||
| 55 | +279 |
- ...) {
+ #' |
||
| 56 | -35x | +|||
| 280 | +
- UseMethod("s_compare", x)
+ #' @examples |
|||
| 57 | +281 |
- }+ #' # Layout creating function with custom format. |
||
| 58 | +282 |
-
+ #' basic_table() %>% |
||
| 59 | +283 |
- #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test+ #' add_colcounts() %>% |
||
| 60 | +284 |
- #' to calculate the p-value.+ #' split_rows_by("SEX", child_labels = "visible") %>%
|
||
| 61 | +285 |
- #'+ #' summarize_occurrences( |
||
| 62 | +286 |
- #' @method s_compare numeric+ #' var = "MHDECOD", |
||
| 63 | +287 |
- #'+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 64 | +288 |
- #' @examples+ #' ) %>% |
||
| 65 | +289 |
- #' # `s_compare.numeric`+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 66 | +290 |
#' |
||
| 67 | +291 |
- #' ## Usual case where both this and the reference group vector have more than 1 value.+ #' @export |
||
| 68 | +292 |
- #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)+ #' @order 3 |
||
| 69 | +293 |
- #'+ summarize_occurrences <- function(lyt, |
||
| 70 | +294 |
- #' ## If one group has not more than 1 value, then p-value is not calculated.+ var, |
||
| 71 | +295 |
- #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)+ id = "USUBJID", |
||
| 72 | +296 |
- #'+ drop = TRUE, |
||
| 73 | +297 |
- #' ## Empty numeric does not fail, it returns NA-filled items and no p-value.+ riskdiff = FALSE, |
||
| 74 | +298 |
- #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)+ na_str = default_na_str(), |
||
| 75 | +299 |
- #'+ ..., |
||
| 76 | +300 |
- #' @export+ .stats = "count_fraction_fixed_dp", |
||
| 77 | +301 |
- s_compare.numeric <- function(x,+ .formats = NULL, |
||
| 78 | +302 |
- .ref_group,+ .indent_mods = NULL, |
||
| 79 | +303 |
- .in_ref_col,+ .labels = NULL) {
|
||
| 80 | -+ | |||
| 304 | +5x |
- ...) {
+ checkmate::assert_flag(riskdiff) |
||
| 81 | -13x | +|||
| 305 | +
- checkmate::assert_numeric(x)+ |
|||
| 82 | -13x | +306 | +5x |
- checkmate::assert_numeric(.ref_group)+ extra_args <- list( |
| 83 | -13x | +307 | +5x |
- checkmate::assert_flag(.in_ref_col)+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 84 | +308 |
-
+ ) |
||
| 85 | -13x | +309 | +5x |
- y <- s_summary.numeric(x = x, ...)+ s_args <- list(id = id, drop = drop, ...) |
| 86 | +310 | |||
| 87 | -13x | +311 | +5x |
- y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
+ if (isFALSE(riskdiff)) {
|
| 88 | -9x | +312 | +1x |
- stats::t.test(x, .ref_group)$p.value+ extra_args <- c(extra_args, s_args) |
| 89 | +313 |
} else {
|
||
| 90 | +314 | 4x |
- character()+ extra_args <- c( |
|
| 91 | -+ | |||
| 315 | +4x |
- }+ extra_args, |
||
| 92 | -+ | |||
| 316 | +4x |
-
+ list( |
||
| 93 | -13x | +317 | +4x |
- y+ afun = list("s_count_occurrences" = a_count_occurrences),
|
| 94 | -+ | |||
| 318 | +4x |
- }+ s_args = s_args |
||
| 95 | +319 |
-
+ ) |
||
| 96 | +320 |
- #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test+ ) |
||
| 97 | +321 |
- #' to calculate the p-value.+ } |
||
| 98 | +322 |
- #'+ |
||
| 99 | -+ | |||
| 323 | +5x |
- #' @param denom (`string`)\cr choice of denominator for factor proportions,+ summarize_row_groups( |
||
| 100 | -+ | |||
| 324 | +5x |
- #' can only be `n` (number of values in this row and column intersection).+ lyt = lyt, |
||
| 101 | -+ | |||
| 325 | +5x |
- #'+ var = var, |
||
| 102 | -+ | |||
| 326 | +5x |
- #' @method s_compare factor+ cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ |
+ ||
| 327 | +5x | +
+ na_str = na_str,+ |
+ ||
| 328 | +5x | +
+ extra_args = extra_args |
||
| 103 | +329 |
- #'+ ) |
||
| 104 | +330 |
- #' @examples+ } |
| 105 | +1 |
- #' # `s_compare.factor`+ #' Convert list of groups to a data frame |
||
| 106 | +2 |
#' |
||
| 107 | +3 |
- #' ## Basic usage:+ #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()]. |
||
| 108 | +4 |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ #' |
||
| 109 | +5 |
- #' y <- factor(c("a", "b", "c"))
+ #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the |
||
| 110 | +6 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)+ #' levels that belong to it in the character vectors that are elements of the list. |
||
| 111 | +7 |
#' |
||
| 112 | +8 |
- #' ## Management of NA values.+ #' @return A `tibble` in the required format. |
||
| 113 | +9 |
- #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
- |
- ||
| 114 | -- |
- #' y <- explicit_na(factor(c("a", "b", "c", NA)))
+ #' |
||
| 115 | +10 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ #' @examples |
||
| 116 | +11 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ #' grade_groups <- list( |
||
| 117 | +12 |
- #'+ #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
|
||
| 118 | +13 |
- #' @export+ #' "Grade 3-4 (%)" = c("3", "4"),
|
||
| 119 | +14 |
- s_compare.factor <- function(x,+ #' "Grade 5 (%)" = "5" |
||
| 120 | +15 |
- .ref_group,+ #' ) |
||
| 121 | +16 |
- .in_ref_col,+ #' groups_list_to_df(grade_groups) |
||
| 122 | +17 |
- denom = "n",+ #' |
||
| 123 | +18 |
- na.rm = TRUE, # nolint+ #' @export |
||
| 124 | +19 |
- ...) {
- |
- ||
| 125 | -16x | -
- checkmate::assert_flag(.in_ref_col)+ groups_list_to_df <- function(groups_list) {
|
||
| 126 | -16x | +20 | +5x |
- assert_valid_factor(x)+ checkmate::assert_list(groups_list, names = "named") |
| 127 | -16x | +21 | +5x |
- assert_valid_factor(.ref_group)+ lapply(groups_list, checkmate::assert_character) |
| 128 | -16x | -
- denom <- match.arg(denom)- |
- ||
| 129 | -+ | 22 | +5x |
-
+ tibble::tibble( |
| 130 | -16x | +23 | +5x |
- y <- s_summary.factor(+ valname = make_names(names(groups_list)), |
| 131 | -16x | +24 | +5x |
- x = x,+ label = names(groups_list), |
| 132 | -16x | +25 | +5x |
- denom = denom,+ levelcombo = unname(groups_list), |
| 133 | -16x | -
- na.rm = na.rm,- |
- ||
| 134 | -+ | 26 | +5x |
- ...+ exargs = replicate(length(groups_list), list()) |
| 135 | +27 |
) |
||
| 136 | -- | - - | -||
| 137 | -16x | -
- if (na.rm) {
- |
- ||
| 138 | -14x | -
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
- |
- ||
| 139 | -14x | -
- .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
- |
- ||
| 140 | -- |
- } else {
- |
- ||
| 141 | -2x | -
- x <- x %>% explicit_na(label = "NA")- |
- ||
| 142 | -2x | -
- .ref_group <- .ref_group %>% explicit_na(label = "NA")- |
- ||
| 143 | -- |
- }- |
- ||
| 144 | +28 | - - | -||
| 145 | -1x | -
- if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
- |
- ||
| 146 | -16x | -
- checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)+ } |
||
| 147 | +29 | |||
| 148 | -16x | -
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
- |
- ||
| 149 | -13x | -
- tab <- rbind(table(x), table(.ref_group))- |
- ||
| 150 | -13x | -
- res <- suppressWarnings(stats::chisq.test(tab))- |
- ||
| 151 | -13x | -
- res$p.value- |
- ||
| 152 | +30 |
- } else {
- |
- ||
| 153 | -3x | -
- character()+ #' Reference and treatment group combination |
||
| 154 | +31 |
- }+ #' |
||
| 155 | +32 | - - | -||
| 156 | -16x | -
- y+ #' @description `r lifecycle::badge("stable")`
|
||
| 157 | +33 |
- }+ #' |
||
| 158 | +34 |
-
+ #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of |
||
| 159 | +35 |
- #' @describeIn compare_variables Method for `character` class. This makes an automatic+ #' columns in the `rtables` framework and teal modules. |
||
| 160 | +36 |
- #' conversion to `factor` (with a warning) and then forwards to the method for factors.+ #' |
||
| 161 | +37 |
- #'+ #' @param fct (`factor`)\cr the variable with levels which needs to be grouped. |
||
| 162 | +38 |
- #' @param verbose (`flag`)\cr whether warnings and messages should be printed. Mainly used+ #' @param ref (`character`)\cr the reference level(s). |
||
| 163 | +39 |
- #' to print out information about factor casting. Defaults to `TRUE`.+ #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`. |
||
| 164 | +40 |
#' |
||
| 165 | +41 |
- #' @method s_compare character+ #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment). |
||
| 166 | +42 |
#' |
||
| 167 | +43 |
#' @examples |
||
| 168 | +44 |
- #' # `s_compare.character`+ #' groups <- combine_groups( |
||
| 169 | +45 |
- #'+ #' fct = DM$ARM, |
||
| 170 | +46 |
- #' ## Basic usage:+ #' ref = c("B: Placebo")
|
||
| 171 | +47 |
- #' x <- c("a", "a", "b", "c", "a")
+ #' ) |
||
| 172 | +48 |
- #' y <- c("a", "b", "c")
+ #' |
||
| 173 | +49 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)+ #' basic_table() %>% |
||
| 174 | +50 |
- #'+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 175 | +51 |
- #' ## Note that missing values handling can make a large difference:+ #' add_colcounts() %>% |
||
| 176 | +52 |
- #' x <- c("a", "a", "b", "c", "a", NA)
+ #' analyze_vars("AGE") %>%
|
||
| 177 | +53 |
- #' y <- c("a", "b", "c", rep(NA, 20))
+ #' build_table(DM) |
||
| 178 | +54 |
- #' s_compare(x,+ #' |
||
| 179 | +55 |
- #' .ref_group = y, .in_ref_col = FALSE,+ #' @export |
||
| 180 | +56 |
- #' .var = "x", verbose = FALSE+ combine_groups <- function(fct, |
||
| 181 | +57 |
- #' )+ ref = NULL, |
||
| 182 | +58 |
- #' s_compare(x,+ collapse = "/") {
|
||
| 183 | -+ | |||
| 59 | +10x |
- #' .ref_group = y, .in_ref_col = FALSE, .var = "x",+ checkmate::assert_string(collapse) |
||
| 184 | -+ | |||
| 60 | +10x |
- #' na.rm = FALSE, verbose = FALSE+ checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE) |
||
| 185 | -+ | |||
| 61 | +10x |
- #' )+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
|
||
| 186 | +62 |
- #'+ |
||
| 187 | -+ | |||
| 63 | +10x |
- #' @export+ fct <- as_factor_keep_attributes(fct) |
||
| 188 | +64 |
- s_compare.character <- function(x,+ |
||
| 189 | -+ | |||
| 65 | +10x |
- .ref_group,+ group_levels <- levels(fct) |
||
| 190 | -+ | |||
| 66 | +10x |
- .in_ref_col,+ if (is.null(ref)) {
|
||
| 191 | -+ | |||
| 67 | +6x |
- denom = "n",+ ref <- group_levels[1] |
||
| 192 | +68 |
- na.rm = TRUE, # nolint+ } else {
|
||
| 193 | -+ | |||
| 69 | +4x |
- .var,+ checkmate::assert_subset(ref, group_levels) |
||
| 194 | +70 |
- verbose = TRUE,+ } |
||
| 195 | +71 |
- ...) {
+
|
||
| 196 | -2x | +72 | +10x |
- x <- as_factor_keep_attributes(x, verbose = verbose)+ groups <- list( |
| 197 | -2x | +73 | +10x |
- .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose)+ ref = group_levels[group_levels %in% ref], |
| 198 | -2x | +74 | +10x |
- s_compare(+ trt = group_levels[!group_levels %in% ref] |
| 199 | -2x | +|||
| 75 | +
- x = x,+ ) |
|||
| 200 | -2x | +76 | +10x |
- .ref_group = .ref_group,+ stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse)) |
| 201 | -2x | +|||
| 77 | +
- .in_ref_col = .in_ref_col,+ } |
|||
| 202 | -2x | +|||
| 78 | +
- denom = denom,+ |
|||
| 203 | -2x | +|||
| 79 | +
- na.rm = na.rm,+ #' Split columns by groups of levels |
|||
| 204 | +80 |
- ...+ #' |
||
| 205 | +81 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 206 | +82 |
- }+ #' |
||
| 207 | +83 |
-
+ #' @inheritParams argument_convention |
||
| 208 | +84 |
- #' @describeIn compare_variables Method for `logical` class. A chi-squared test+ #' @inheritParams groups_list_to_df |
||
| 209 | +85 |
- #' is used. If missing values are not removed, then they are counted as `FALSE`.+ #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to |
||
| 210 | +86 |
- #'+ #' control formats (`format`), add a joint column for all groups (`incl_all`). |
||
| 211 | +87 |
- #' @method s_compare logical+ #' |
||
| 212 | +88 |
- #'+ #' @return A layout object suitable for passing to further layouting functions. Adding |
||
| 213 | +89 |
- #' @examples+ #' this function to an `rtable` layout will add a column split including the given |
||
| 214 | +90 |
- #' # `s_compare.logical`+ #' groups to the table layout. |
||
| 215 | +91 |
#' |
||
| 216 | +92 |
- #' ## Basic usage:+ #' @seealso [rtables::split_cols_by()] |
||
| 217 | +93 |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ #' |
||
| 218 | +94 |
- #' y <- c(FALSE, FALSE, TRUE)+ #' @examples |
||
| 219 | +95 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE)+ #' # 1 - Basic use |
||
| 220 | +96 |
#' |
||
| 221 | +97 |
- #' ## Management of NA values.+ #' # Without group combination `split_cols_by_groups` is |
||
| 222 | +98 |
- #' x <- c(NA, TRUE, FALSE)+ #' # equivalent to [rtables::split_cols_by()]. |
||
| 223 | +99 |
- #' y <- c(NA, NA, NA, NA, FALSE)+ #' basic_table() %>% |
||
| 224 | +100 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ #' split_cols_by_groups("ARM") %>%
|
||
| 225 | +101 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ #' add_colcounts() %>% |
||
| 226 | +102 |
- #'+ #' analyze("AGE") %>%
|
||
| 227 | +103 |
- #' @export+ #' build_table(DM) |
||
| 228 | +104 |
- s_compare.logical <- function(x,+ #' |
||
| 229 | +105 |
- .ref_group,+ #' # Add a reference column. |
||
| 230 | +106 |
- .in_ref_col,+ #' basic_table() %>% |
||
| 231 | +107 |
- na.rm = TRUE, # nolint+ #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
|
||
| 232 | +108 |
- denom = "n",+ #' add_colcounts() %>% |
||
| 233 | +109 |
- ...) {
- |
- ||
| 234 | -4x | -
- denom <- match.arg(denom)+ #' analyze( |
||
| 235 | +110 |
-
+ #' "AGE", |
||
| 236 | -4x | +|||
| 111 | +
- y <- s_summary.logical(+ #' afun = function(x, .ref_group, .in_ref_col) {
|
|||
| 237 | -4x | +|||
| 112 | +
- x = x,+ #' if (.in_ref_col) {
|
|||
| 238 | -4x | +|||
| 113 | +
- na.rm = na.rm,+ #' in_rows("Diff Mean" = rcell(NULL))
|
|||
| 239 | -4x | +|||
| 114 | +
- denom = denom,+ #' } else {
|
|||
| 240 | +115 |
- ...+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 241 | +116 |
- )+ #' } |
||
| 242 | +117 |
-
+ #' } |
||
| 243 | -4x | +|||
| 118 | +
- if (na.rm) {
+ #' ) %>% |
|||
| 244 | -3x | +|||
| 119 | +
- x <- stats::na.omit(x)+ #' build_table(DM) |
|||
| 245 | -3x | +|||
| 120 | +
- .ref_group <- stats::na.omit(.ref_group)+ #' |
|||
| 246 | +121 |
- } else {
+ #' # 2 - Adding group specification |
||
| 247 | -1x | +|||
| 122 | +
- x[is.na(x)] <- FALSE+ #' |
|||
| 248 | -1x | +|||
| 123 | +
- .ref_group[is.na(.ref_group)] <- FALSE+ #' # Manual preparation of the groups. |
|||
| 249 | +124 |
- }+ #' groups <- list( |
||
| 250 | +125 |
-
+ #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
|
||
| 251 | -4x | +|||
| 126 | +
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ #' "Arms A+C" = c("A: Drug X", "C: Combination")
|
|||
| 252 | -4x | +|||
| 127 | +
- x <- factor(x, levels = c(TRUE, FALSE))+ #' ) |
|||
| 253 | -4x | +|||
| 128 | +
- .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))+ #' |
|||
| 254 | -4x | +|||
| 129 | +
- tbl <- rbind(table(x), table(.ref_group))+ #' # Use of split_cols_by_groups without reference column. |
|||
| 255 | -4x | +|||
| 130 | +
- suppressWarnings(prop_chisq(tbl))+ #' basic_table() %>% |
|||
| 256 | +131 |
- } else {
+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 257 | -! | +|||
| 132 | +
- character()+ #' add_colcounts() %>% |
|||
| 258 | +133 |
- }+ #' analyze("AGE") %>%
|
||
| 259 | +134 |
-
+ #' build_table(DM) |
||
| 260 | -4x | +|||
| 135 | +
- y+ #' |
|||
| 261 | +136 |
- }+ #' # Including differentiated output in the reference column. |
||
| 262 | +137 |
-
+ #' basic_table() %>% |
||
| 263 | +138 |
- #' @describeIn compare_variables Layout-creating function which can take statistics function arguments+ #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
|
||
| 264 | +139 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' analyze( |
||
| 265 | +140 |
- #'+ #' "AGE", |
||
| 266 | +141 |
- #' @param ... arguments passed to `s_compare()`.+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 267 | +142 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' if (.in_ref_col) {
|
||
| 268 | +143 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' in_rows("Diff. of Averages" = rcell(NULL))
|
||
| 269 | +144 |
- #' for that statistic's row label.+ #' } else {
|
||
| 270 | +145 |
- #'+ #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 271 | +146 |
- #' @return+ #' } |
||
| 272 | +147 |
- #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions,+ #' } |
||
| 273 | +148 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' ) %>% |
||
| 274 | +149 |
- #' the statistics from `s_compare()` to the table layout.+ #' build_table(DM) |
||
| 275 | +150 |
#' |
||
| 276 | +151 |
- #' @examples+ #' # 3 - Binary list dividing factor levels into reference and treatment |
||
| 277 | +152 |
- #' # `compare_vars()` in `rtables` pipelines+ #' |
||
| 278 | +153 |
- #'+ #' # `combine_groups` defines reference and treatment. |
||
| 279 | +154 |
- #' ## Default output within a `rtables` pipeline.+ #' groups <- combine_groups( |
||
| 280 | +155 |
- #' lyt <- basic_table() %>%+ #' fct = DM$ARM, |
||
| 281 | +156 |
- #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
+ #' ref = c("A: Drug X", "B: Placebo")
|
||
| 282 | +157 |
- #' compare_vars(c("AGE", "SEX"))
+ #' ) |
||
| 283 | +158 |
- #' build_table(lyt, tern_ex_adsl)+ #' groups |
||
| 284 | +159 |
#' |
||
| 285 | +160 |
- #' ## Select and format statistics output.+ #' # Use group definition without reference column. |
||
| 286 | +161 |
- #' lyt <- basic_table() %>%+ #' basic_table() %>% |
||
| 287 | +162 |
- #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
+ #' split_cols_by_groups("ARM", groups_list = groups) %>%
|
||
| 288 | +163 |
- #' compare_vars(+ #' add_colcounts() %>% |
||
| 289 | +164 |
- #' vars = "AGE",+ #' analyze("AGE") %>%
|
||
| 290 | +165 |
- #' .stats = c("mean_sd", "pval"),
+ #' build_table(DM) |
||
| 291 | +166 |
- #' .formats = c(mean_sd = "xx.x, xx.x"),+ #' |
||
| 292 | +167 |
- #' .labels = c(mean_sd = "Mean, SD")+ #' # Use group definition with reference column (first item of groups). |
||
| 293 | +168 |
- #' )+ #' basic_table() %>% |
||
| 294 | +169 |
- #' build_table(lyt, df = tern_ex_adsl)+ #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
|
||
| 295 | +170 |
- #'+ #' add_colcounts() %>% |
||
| 296 | +171 |
- #' @export+ #' analyze( |
||
| 297 | +172 |
- #' @order 2+ #' "AGE", |
||
| 298 | +173 |
- compare_vars <- function(lyt,+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 299 | +174 |
- vars,+ #' if (.in_ref_col) {
|
||
| 300 | +175 |
- var_labels = vars,+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 301 | +176 |
- na_str = default_na_str(),+ #' } else {
|
||
| 302 | +177 |
- nested = TRUE,+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 303 | +178 |
- ...,+ #' } |
||
| 304 | +179 |
- na.rm = TRUE, # nolint+ #' } |
||
| 305 | +180 |
- show_labels = "default",+ #' ) %>% |
||
| 306 | +181 |
- table_names = vars,+ #' build_table(DM) |
||
| 307 | +182 |
- section_div = NA_character_,+ #' |
||
| 308 | +183 |
- .stats = c("n", "mean_sd", "count_fraction", "pval"),
+ #' @export |
||
| 309 | +184 |
- .formats = NULL,+ split_cols_by_groups <- function(lyt, |
||
| 310 | +185 |
- .labels = NULL,+ var, |
||
| 311 | +186 |
- .indent_mods = NULL) {
+ groups_list = NULL, |
||
| 312 | -4x | +|||
| 187 | +
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...)+ ref_group = NULL, |
|||
| 313 | +188 |
-
+ ...) {
|
||
| 314 | -1x | +189 | +6x |
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ if (is.null(groups_list)) {
|
| 315 | -1x | -
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels- |
- ||
| 316 | -! | +190 | +2x |
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ split_cols_by( |
| 317 | -+ | |||
| 191 | +2x |
-
+ lyt = lyt, |
||
| 318 | -4x | +192 | +2x |
- analyze(+ var = var, |
| 319 | -4x | +193 | +2x |
- lyt = lyt,+ ref_group = ref_group,+ |
+
| 194 | ++ |
+ ...+ |
+ ||
| 195 | ++ |
+ )+ |
+ ||
| 196 | ++ |
+ } else {
|
||
| 320 | +197 | 4x |
- vars = vars,+ groups_df <- groups_list_to_df(groups_list) |
|
| 321 | +198 | 4x |
- var_labels = var_labels,+ if (!is.null(ref_group)) {
|
|
| 322 | +199 | +3x | +
+ ref_group <- groups_df$valname[groups_df$label == ref_group]+ |
+ |
| 200 | ++ |
+ }+ |
+ ||
| 201 | 4x |
- afun = a_summary,+ split_cols_by( |
||
| 323 | +202 | 4x |
- na_str = na_str,+ lyt = lyt, |
|
| 324 | +203 | 4x |
- nested = nested,+ var = var, |
|
| 325 | +204 | 4x |
- extra_args = extra_args,+ split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname), |
|
| 326 | +205 | 4x |
- inclNAs = TRUE,+ ref_group = ref_group,+ |
+ |
| 206 | ++ |
+ ...+ |
+ ||
| 207 | ++ |
+ )+ |
+ ||
| 208 | ++ |
+ }+ |
+ ||
| 209 | ++ |
+ }+ |
+ ||
| 210 | ++ | + + | +||
| 211 | ++ |
+ #' Combine counts+ |
+ ||
| 212 | ++ |
+ #'+ |
+ ||
| 213 | ++ |
+ #' Simplifies the estimation of column counts, especially when group combination is required.+ |
+ ||
| 214 | ++ |
+ #'+ |
+ ||
| 215 | ++ |
+ #' @inheritParams combine_groups+ |
+ ||
| 216 | ++ |
+ #' @inheritParams groups_list_to_df+ |
+ ||
| 217 | ++ |
+ #'+ |
+ ||
| 218 | ++ |
+ #' @return A `vector` of column counts.+ |
+ ||
| 219 | ++ |
+ #'+ |
+ ||
| 220 | ++ |
+ #' @seealso [combine_groups()]+ |
+ ||
| 221 | ++ |
+ #'+ |
+ ||
| 222 | ++ |
+ #' @examples+ |
+ ||
| 223 | ++ |
+ #' ref <- c("A: Drug X", "B: Placebo")
+ |
+ ||
| 224 | ++ |
+ #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ |
+ ||
| 225 | ++ |
+ #'+ |
+ ||
| 226 | ++ |
+ #' col_counts <- combine_counts(+ |
+ ||
| 227 | ++ |
+ #' fct = DM$ARM,+ |
+ ||
| 228 | ++ |
+ #' groups_list = groups+ |
+ ||
| 229 | ++ |
+ #' )+ |
+ ||
| 230 | ++ |
+ #'+ |
+ ||
| 231 | ++ |
+ #' basic_table() %>%+ |
+ ||
| 232 | ++ |
+ #' split_cols_by_groups("ARM", groups) %>%
+ |
+ ||
| 233 | ++ |
+ #' add_colcounts() %>%+ |
+ ||
| 234 | ++ |
+ #' analyze_vars("AGE") %>%
+ |
+ ||
| 235 | ++ |
+ #' build_table(DM, col_counts = col_counts)+ |
+ ||
| 236 | ++ |
+ #'+ |
+ ||
| 237 | ++ |
+ #' ref <- "A: Drug X"+ |
+ ||
| 238 | ++ |
+ #' 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) {
|
||
| 327 | +252 | 4x |
- show_labels = show_labels,+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ |
+ |
| 253 | ++ | + | ||
| 328 | +254 | 4x |
- table_names = table_names,+ fct <- as_factor_keep_attributes(fct)+ |
+ |
| 255 | ++ | + | ||
| 329 | +256 | 4x |
- section_div = section_div+ if (is.null(groups_list)) {
+ |
+ |
| 257 | +1x | +
+ y <- table(fct)+ |
+ ||
| 258 | +1x | +
+ y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]]) |
||
| 330 | +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 |
||
| 331 | +264 | ++ |
+ )+ |
+ |
| 265 | ++ |
+ }+ |
+ ||
| 266 | +4x | +
+ y+ |
+ ||
| 267 |
}@@ -128310,14 +126847,14 @@ tern coverage - 95.65% |
| 1 |
- #' Convert list of groups to a data frame+ #' Helper functions for tabulating binary response by subgroup |
||
| 3 |
- #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the+ #' Helper functions that tabulate in a data frame statistics such as response rate |
||
| 6 |
- #' levels that belong to it in the character vectors that are elements of the list.+ #' and odds ratio for population subgroups. |
||
| 8 |
- #' @return A `tibble` in the required format.+ #' @inheritParams argument_convention |
||
| 9 |
- #'+ #' @inheritParams response_subgroups |
||
| 10 |
- #' @examples+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 11 |
- #' grade_groups <- list(+ #' |
||
| 12 |
- #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 13 |
- #' "Grade 3-4 (%)" = c("3", "4"),
+ #' |
||
| 14 |
- #' "Grade 5 (%)" = "5"+ #' @examples |
||
| 15 |
- #' )+ #' library(dplyr) |
||
| 16 |
- #' groups_list_to_df(grade_groups)+ #' library(forcats) |
||
| 18 |
- #' @export+ #' adrs <- tern_ex_adrs |
||
| 19 |
- groups_list_to_df <- function(groups_list) {
+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 20 | -5x | +
- checkmate::assert_list(groups_list, names = "named")+ #' |
|
| 21 | -5x | +
- lapply(groups_list, checkmate::assert_character)+ #' adrs_f <- adrs %>% |
|
| 22 | -5x | +
- tibble::tibble(+ #' filter(PARAMCD == "BESRSPI") %>% |
|
| 23 | -5x | +
- valname = make_names(names(groups_list)),+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
|
| 24 | -5x | +
- label = names(groups_list),+ #' droplevels() %>% |
|
| 25 | -5x | +
- levelcombo = unname(groups_list),+ #' mutate( |
|
| 26 | -5x | +
- exargs = replicate(length(groups_list), list())+ #' # Reorder levels of factor to make the placebo group the reference arm. |
|
| 27 |
- )+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 28 |
- }+ #' rsp = AVALC == "CR" |
||
| 29 |
-
+ #' ) |
||
| 30 |
- #' Reference and treatment group combination+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 32 |
- #' @description `r lifecycle::badge("stable")`
+ #' @name h_response_subgroups |
||
| 33 |
- #'+ NULL |
||
| 34 |
- #' 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.+ #' @describeIn h_response_subgroups Helper to prepare a data frame of binary responses by arm. |
||
| 37 |
- #' @param fct (`factor`)\cr the variable with levels which needs to be grouped.+ #' @return |
||
| 38 |
- #' @param ref (`character`)\cr the reference level(s).+ #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`. |
||
| 39 |
- #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`.+ #' |
||
| 40 |
- #'+ #' @examples |
||
| 41 |
- #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment).+ #' h_proportion_df( |
||
| 42 |
- #'+ #' c(TRUE, FALSE, FALSE), |
||
| 43 |
- #' @examples+ #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
|
||
| 44 |
- #' groups <- combine_groups(+ #' ) |
||
| 45 |
- #' fct = DM$ARM,+ #' |
||
| 46 |
- #' ref = c("B: Placebo")
+ #' @export |
||
| 47 |
- #' )+ h_proportion_df <- function(rsp, arm) {
|
||
| 48 | -+ | 79x |
- #'+ checkmate::assert_logical(rsp) |
| 49 | -+ | 78x |
- #' basic_table() %>%+ assert_valid_factor(arm, len = length(rsp)) |
| 50 | -+ | 78x |
- #' split_cols_by_groups("ARM", groups) %>%
+ non_missing_rsp <- !is.na(rsp) |
| 51 | -+ | 78x |
- #' add_colcounts() %>%+ rsp <- rsp[non_missing_rsp] |
| 52 | -+ | 78x |
- #' analyze_vars("AGE") %>%
+ arm <- arm[non_missing_rsp] |
| 53 |
- #' build_table(DM)+ |
||
| 54 | -+ | 78x |
- #'+ lst_rsp <- split(rsp, arm) |
| 55 | -+ | 78x |
- #' @export+ lst_results <- Map(function(x, arm) {
|
| 56 | -+ | 156x |
- combine_groups <- function(fct,+ if (length(x) > 0) {
|
| 57 | -+ | 154x |
- ref = NULL,+ s_prop <- s_proportion(df = x) |
| 58 | -+ | 154x |
- collapse = "/") {
+ data.frame( |
| 59 | -10x | +154x |
- checkmate::assert_string(collapse)+ arm = arm, |
| 60 | -10x | +154x |
- checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE)+ n = length(x), |
| 61 | -10x | +154x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ n_rsp = unname(s_prop$n_prop[1]), |
| 62 | -+ | 154x |
-
+ prop = unname(s_prop$n_prop[2]), |
| 63 | -10x | +154x |
- fct <- as_factor_keep_attributes(fct)+ stringsAsFactors = FALSE |
| 64 |
-
+ ) |
||
| 65 | -10x | +
- group_levels <- levels(fct)+ } else {
|
|
| 66 | -10x | +2x |
- if (is.null(ref)) {
+ data.frame( |
| 67 | -6x | +2x |
- ref <- group_levels[1]+ arm = arm, |
| 68 | -+ | 2x |
- } else {
+ n = 0L, |
| 69 | -4x | +2x |
- checkmate::assert_subset(ref, group_levels)+ n_rsp = NA, |
| 70 | -+ | 2x |
- }+ prop = NA, |
| 71 | -+ | 2x |
-
+ stringsAsFactors = FALSE |
| 72 | -10x | +
- groups <- list(+ ) |
|
| 73 | -10x | +
- ref = group_levels[group_levels %in% ref],+ } |
|
| 74 | -10x | +78x |
- trt = group_levels[!group_levels %in% ref]+ }, lst_rsp, names(lst_rsp)) |
| 75 |
- )+ |
||
| 76 | -10x | +78x |
- stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse))+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 77 | -+ | 78x |
- }+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 78 | -+ | 78x |
-
+ df |
| 79 |
- #' Split columns by groups of levels+ } |
||
| 80 |
- #'+ |
||
| 81 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn h_response_subgroups Summarizes proportion of binary responses by arm and across subgroups |
||
| 82 |
- #'+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 83 |
- #' @inheritParams argument_convention+ #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 84 |
- #' @inheritParams groups_list_to_df+ #' groupings for `subgroups` variables. |
||
| 85 |
- #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to+ #' |
||
| 86 |
- #' control formats (`format`), add a joint column for all groups (`incl_all`).+ #' @return |
||
| 87 |
- #'+ #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, |
||
| 88 |
- #' @return A layout object suitable for passing to further layouting functions. Adding+ #' `var`, `var_label`, and `row_type`. |
||
| 89 |
- #' this function to an `rtable` layout will add a column split including the given+ #' |
||
| 90 |
- #' groups to the table layout.+ #' @examples |
||
| 91 |
- #'+ #' h_proportion_subgroups_df( |
||
| 92 |
- #' @seealso [rtables::split_cols_by()]+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 93 |
- #'+ #' data = adrs_f |
||
| 94 |
- #' @examples+ #' ) |
||
| 95 |
- #' # 1 - Basic use+ #' |
||
| 96 |
- #'+ #' # Define groupings for BMRKR2 levels. |
||
| 97 |
- #' # Without group combination `split_cols_by_groups` is+ #' h_proportion_subgroups_df( |
||
| 98 |
- #' # equivalent to [rtables::split_cols_by()].+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 99 |
- #' basic_table() %>%+ #' data = adrs_f, |
||
| 100 |
- #' split_cols_by_groups("ARM") %>%
+ #' groups_lists = list( |
||
| 101 |
- #' add_colcounts() %>%+ #' BMRKR2 = list( |
||
| 102 |
- #' analyze("AGE") %>%
+ #' "low" = "LOW", |
||
| 103 |
- #' build_table(DM)+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 104 |
- #'+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 105 |
- #' # Add a reference column.+ #' ) |
||
| 106 |
- #' basic_table() %>%+ #' ) |
||
| 107 |
- #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
+ #' ) |
||
| 108 |
- #' add_colcounts() %>%+ #' |
||
| 109 |
- #' analyze(+ #' @export |
||
| 110 |
- #' "AGE",+ h_proportion_subgroups_df <- function(variables, |
||
| 111 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ data, |
||
| 112 |
- #' if (.in_ref_col) {
+ groups_lists = list(), |
||
| 113 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ label_all = "All Patients") {
|
||
| 114 | -+ | 17x |
- #' } else {
+ checkmate::assert_character(variables$rsp) |
| 115 | -+ | 17x |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ checkmate::assert_character(variables$arm) |
| 116 | -+ | 17x |
- #' }+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 117 | -+ | 17x |
- #' }+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 118 | -+ | 17x |
- #' ) %>%+ assert_df_with_variables(data, variables) |
| 119 | -+ | 17x |
- #' build_table(DM)+ checkmate::assert_string(label_all) |
| 120 |
- #'+ |
||
| 121 |
- #' # 2 - Adding group specification+ # Add All Patients. |
||
| 122 | -+ | 17x |
- #'+ result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]]) |
| 123 | -+ | 17x |
- #' # Manual preparation of the groups.+ result_all$subgroup <- label_all |
| 124 | -+ | 17x |
- #' groups <- list(+ result_all$var <- "ALL" |
| 125 | -+ | 17x |
- #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
+ result_all$var_label <- label_all |
| 126 | -+ | 17x |
- #' "Arms A+C" = c("A: Drug X", "C: Combination")
+ result_all$row_type <- "content" |
| 127 |
- #' )+ |
||
| 128 |
- #'+ # Add Subgroups. |
||
| 129 | -+ | 17x |
- #' # Use of split_cols_by_groups without reference column.+ if (is.null(variables$subgroups)) {
|
| 130 | -+ | 3x |
- #' basic_table() %>%+ result_all |
| 131 |
- #' split_cols_by_groups("ARM", groups) %>%
+ } else {
|
||
| 132 | -+ | 14x |
- #' add_colcounts() %>%+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 133 |
- #' analyze("AGE") %>%
+
|
||
| 134 | -+ | 14x |
- #' build_table(DM)+ l_result <- lapply(l_data, function(grp) {
|
| 135 | -+ | 58x |
- #'+ result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]]) |
| 136 | -+ | 58x |
- #' # Including differentiated output in the reference column.+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 137 | -+ | 58x |
- #' basic_table() %>%+ cbind(result, result_labels) |
| 138 |
- #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
+ }) |
||
| 139 | -+ | 14x |
- #' analyze(+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 140 | -+ | 14x |
- #' "AGE",+ result_subgroups$row_type <- "analysis" |
| 141 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+
|
||
| 142 | -+ | 14x |
- #' if (.in_ref_col) {
+ rbind( |
| 143 | -+ | 14x |
- #' in_rows("Diff. of Averages" = rcell(NULL))
+ result_all, |
| 144 | -+ | 14x |
- #' } else {
+ result_subgroups |
| 145 |
- #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ ) |
||
| 146 |
- #' }+ } |
||
| 147 |
- #' }+ } |
||
| 148 |
- #' ) %>%+ |
||
| 149 |
- #' build_table(DM)+ #' @describeIn h_response_subgroups Helper to prepare a data frame with estimates of |
||
| 150 |
- #'+ #' the odds ratio between a treatment and a control arm. |
||
| 151 |
- #' # 3 - Binary list dividing factor levels into reference and treatment+ #' |
||
| 152 |
- #'+ #' @inheritParams response_subgroups |
||
| 153 |
- #' # `combine_groups` defines reference and treatment.+ #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed. |
||
| 154 |
- #' groups <- combine_groups(+ #' |
||
| 155 |
- #' fct = DM$ARM,+ #' @return |
||
| 156 |
- #' ref = c("A: Drug X", "B: Placebo")
+ #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and |
||
| 157 |
- #' )+ #' optionally `pval` and `pval_label`. |
||
| 158 |
- #' groups+ #' |
||
| 159 |
- #'+ #' @examples |
||
| 160 |
- #' # Use group definition without reference column.+ #' # Unstratatified analysis. |
||
| 161 |
- #' basic_table() %>%+ #' h_odds_ratio_df( |
||
| 162 |
- #' split_cols_by_groups("ARM", groups_list = groups) %>%
+ #' c(TRUE, FALSE, FALSE, TRUE), |
||
| 163 |
- #' add_colcounts() %>%+ #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 164 |
- #' analyze("AGE") %>%
+ #' ) |
||
| 165 |
- #' build_table(DM)+ #' |
||
| 166 |
- #'+ #' # Include p-value. |
||
| 167 |
- #' # Use group definition with reference column (first item of groups).+ #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq") |
||
| 168 |
- #' basic_table() %>%+ #' |
||
| 169 |
- #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
+ #' # Stratatified analysis. |
||
| 170 |
- #' add_colcounts() %>%+ #' h_odds_ratio_df( |
||
| 171 |
- #' analyze(+ #' rsp = adrs_f$rsp, |
||
| 172 |
- #' "AGE",+ #' arm = adrs_f$ARM, |
||
| 173 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
|
||
| 174 |
- #' if (.in_ref_col) {
+ #' method = "cmh" |
||
| 175 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ #' ) |
||
| 176 |
- #' } else {
+ #' |
||
| 177 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ #' @export |
||
| 178 |
- #' }+ h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
|
||
| 179 | -+ | 84x |
- #' }+ assert_valid_factor(arm, n.levels = 2, len = length(rsp)) |
| 180 |
- #' ) %>%+ |
||
| 181 | -+ | 84x |
- #' build_table(DM)+ df_rsp <- data.frame( |
| 182 | -+ | 84x |
- #'+ rsp = rsp, |
| 183 | -+ | 84x |
- #' @export+ arm = arm |
| 184 |
- split_cols_by_groups <- function(lyt,+ ) |
||
| 185 |
- var,+ |
||
| 186 | -+ | 84x |
- groups_list = NULL,+ if (!is.null(strata_data)) {
|
| 187 | -+ | 11x |
- ref_group = NULL,+ strata_var <- interaction(strata_data, drop = TRUE) |
| 188 | -+ | 11x |
- ...) {
+ strata_name <- "strata" |
| 189 | -6x | +
- if (is.null(groups_list)) {
+
|
|
| 190 | -2x | +11x |
- split_cols_by(+ assert_valid_factor(strata_var, len = nrow(df_rsp)) |
| 191 | -2x | +
- lyt = lyt,+ |
|
| 192 | -2x | +11x |
- var = var,+ df_rsp[[strata_name]] <- strata_var |
| 193 | -2x | +
- ref_group = ref_group,+ } else {
|
|
| 194 | -+ | 73x |
- ...+ strata_name <- NULL |
| 195 |
- )+ } |
||
| 196 |
- } else {
+
|
||
| 197 | -4x | +84x |
- groups_df <- groups_list_to_df(groups_list)+ l_df <- split(df_rsp, arm) |
| 198 | -4x | +
- if (!is.null(ref_group)) {
+
|
|
| 199 | -3x | +84x |
- ref_group <- groups_df$valname[groups_df$label == ref_group]+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
| 200 |
- }+ # Odds ratio and CI. |
||
| 201 | -4x | +82x |
- split_cols_by(+ result_odds_ratio <- s_odds_ratio( |
| 202 | -4x | +82x |
- lyt = lyt,+ df = l_df[[2]], |
| 203 | -4x | +82x |
- var = var,+ .var = "rsp", |
| 204 | -4x | +82x |
- split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname),+ .ref_group = l_df[[1]], |
| 205 | -4x | +82x |
- ref_group = ref_group,+ .in_ref_col = FALSE, |
| 206 | -+ | 82x |
- ...+ .df_row = df_rsp, |
| 207 | -+ | 82x |
- )+ variables = list(arm = "arm", strata = strata_name), |
| 208 | -+ | 82x |
- }+ conf_level = conf_level |
| 209 |
- }+ ) |
||
| 211 | -+ | 82x |
- #' Combine counts+ df <- data.frame( |
| 212 |
- #'+ # Dummy column needed downstream to create a nested header. |
||
| 213 | -+ | 82x |
- #' Simplifies the estimation of column counts, especially when group combination is required.+ arm = " ", |
| 214 | -+ | 82x |
- #'+ n_tot = unname(result_odds_ratio$n_tot["n_tot"]), |
| 215 | -+ | 82x |
- #' @inheritParams combine_groups+ or = unname(result_odds_ratio$or_ci["est"]), |
| 216 | -+ | 82x |
- #' @inheritParams groups_list_to_df+ lcl = unname(result_odds_ratio$or_ci["lcl"]), |
| 217 | -+ | 82x |
- #'+ ucl = unname(result_odds_ratio$or_ci["ucl"]), |
| 218 | -+ | 82x |
- #' @return A `vector` of column counts.+ conf_level = conf_level, |
| 219 | -+ | 82x |
- #'+ stringsAsFactors = FALSE |
| 220 |
- #' @seealso [combine_groups()]+ ) |
||
| 221 |
- #'+ |
||
| 222 | -+ | 82x |
- #' @examples+ if (!is.null(method)) {
|
| 223 |
- #' ref <- c("A: Drug X", "B: Placebo")
+ # Test for difference. |
||
| 224 | -+ | 44x |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ result_test <- s_test_proportion_diff( |
| 225 | -+ | 44x |
- #'+ df = l_df[[2]], |
| 226 | -+ | 44x |
- #' col_counts <- combine_counts(+ .var = "rsp", |
| 227 | -+ | 44x |
- #' fct = DM$ARM,+ .ref_group = l_df[[1]], |
| 228 | -+ | 44x |
- #' groups_list = groups+ .in_ref_col = FALSE, |
| 229 | -+ | 44x |
- #' )+ variables = list(strata = strata_name), |
| 230 | -+ | 44x |
- #'+ method = method |
| 231 |
- #' basic_table() %>%+ ) |
||
| 232 |
- #' split_cols_by_groups("ARM", groups) %>%
+
|
||
| 233 | -+ | 44x |
- #' add_colcounts() %>%+ df$pval <- as.numeric(result_test$pval) |
| 234 | -+ | 44x |
- #' analyze_vars("AGE") %>%
+ df$pval_label <- obj_label(result_test$pval) |
| 235 |
- #' build_table(DM, col_counts = col_counts)+ } |
||
| 236 |
- #'+ |
||
| 237 |
- #' ref <- "A: Drug X"+ # In those cases cannot go through the model so will obtain n_tot from data. |
||
| 238 |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ } else if ( |
||
| 239 | -+ | 2x |
- #' col_counts <- combine_counts(+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
| 240 | -+ | 2x |
- #' fct = DM$ARM,+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
| 241 |
- #' groups_list = groups+ ) {
|
||
| 242 | -+ | 2x |
- #' )+ df <- data.frame( |
| 243 |
- #'+ # Dummy column needed downstream to create a nested header. |
||
| 244 | -+ | 2x |
- #' basic_table() %>%+ arm = " ", |
| 245 | -+ | 2x |
- #' split_cols_by_groups("ARM", groups) %>%
+ n_tot = sum(stats::complete.cases(df_rsp)), |
| 246 | -+ | 2x |
- #' add_colcounts() %>%+ or = NA, |
| 247 | -+ | 2x |
- #' analyze_vars("AGE") %>%
+ lcl = NA, |
| 248 | -+ | 2x |
- #' build_table(DM, col_counts = col_counts)+ ucl = NA, |
| 249 | -+ | 2x |
- #'+ conf_level = conf_level, |
| 250 | -+ | 2x |
- #' @export+ stringsAsFactors = FALSE |
| 251 |
- combine_counts <- function(fct, groups_list = NULL) {
+ ) |
||
| 252 | -4x | +2x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ if (!is.null(method)) {
|
| 253 | -+ | 2x |
-
+ df$pval <- NA |
| 254 | -4x | +2x |
- fct <- as_factor_keep_attributes(fct)+ df$pval_label <- NA |
| 255 |
-
+ } |
||
| 256 | -4x | +
- if (is.null(groups_list)) {
+ } else {
|
|
| 257 | -1x | +! |
- y <- table(fct)+ df <- data.frame( |
| 258 | -1x | +
- y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ # Dummy column needed downstream to create a nested header. |
|
| 259 | -+ | ! |
- } else {
+ arm = " ", |
| 260 | -3x | +! |
- y <- vapply(+ n_tot = 0L, |
| 261 | -3x | +! |
- X = groups_list,+ or = NA, |
| 262 | -3x | +! |
- FUN = function(x) sum(table(fct)[x]),+ lcl = NA, |
| 263 | -3x | +! |
- FUN.VALUE = 1+ ucl = NA, |
| 264 | -+ | ! |
- )+ conf_level = conf_level, |
| 265 | -- |
- }- |
- |
| 266 | -4x | +! |
- y+ stringsAsFactors = FALSE |
| 267 | +266 |
- }+ ) |
| 1 | +267 |
- #' Count patients with toxicity grades that have worsened from baseline by highest grade post-baseline+ |
||
| 2 | -+ | |||
| 268 | +! |
- #'+ if (!is.null(method)) {
|
||
| 3 | -+ | |||
| 269 | +! |
- #' @description `r lifecycle::badge("stable")`
+ df$pval <- NA |
||
| 4 | -+ | |||
| 270 | +! |
- #'+ df$pval_label <- NA |
||
| 5 | +271 |
- #' The analyze function [count_abnormal_lab_worsen_by_baseline()] creates a layout element to count patients with+ } |
||
| 6 | +272 |
- #' analysis toxicity grades which have worsened from baseline, categorized by highest (worst) grade post-baseline.+ } |
||
| 7 | +273 |
- #'+ |
||
| 8 | -+ | |||
| 274 | +84x |
- #' This function analyzes primary analysis variable `var` which indicates analysis toxicity grades. Additional+ df |
||
| 9 | +275 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to `USUBJID`),+ } |
||
| 10 | +276 |
- #' a variable to indicate unique subject identifiers, `baseline_var` (defaults to `BTOXGR`), a variable to indicate+ |
||
| 11 | +277 |
- #' baseline toxicity grades, and `direction_var` (defaults to `GRADDIR`), a variable to indicate toxicity grade+ #' @describeIn h_response_subgroups Summarizes estimates of the odds ratio between a treatment and a control |
||
| 12 | +278 |
- #' directions of interest to include (e.g. `"H"` (high), `"L"` (low), or `"B"` (both)).+ #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in |
||
| 13 | +279 |
- #'+ #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups` |
||
| 14 | +280 |
- #' For the direction(s) specified in `direction_var`, patient counts by worst grade for patients who have+ #' and `strata`. `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 15 | +281 |
- #' worsened from baseline are calculated as follows:+ #' |
||
| 16 | +282 |
- #' * `1` to `4`: The number of patients who have worsened from their baseline grades with worst+ #' @return |
||
| 17 | +283 |
- #' grades 1-4, respectively.+ #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, |
||
| 18 | +284 |
- #' * `Any`: The total number of patients who have worsened from their baseline grades.+ #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 19 | +285 |
#' |
||
| 20 | +286 |
- #' Fractions are calculated by dividing the above counts by the number of patients who's analysis toxicity grades+ #' @examples |
||
| 21 | +287 |
- #' have worsened from baseline toxicity grades during treatment.+ #' # Unstratified analysis. |
||
| 22 | +288 |
- #'+ #' h_odds_ratio_subgroups_df( |
||
| 23 | +289 |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create a row+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 24 | +290 |
- #' split on variable `direction_var`.+ #' data = adrs_f |
||
| 25 | +291 |
- #'+ #' ) |
||
| 26 | +292 |
- #' @inheritParams argument_convention+ #' |
||
| 27 | +293 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables including:+ #' # Stratified analysis. |
||
| 28 | +294 |
- #' * `id` (`string`)\cr subject variable name.+ #' h_odds_ratio_subgroups_df( |
||
| 29 | +295 |
- #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.+ #' variables = list( |
||
| 30 | +296 |
- #' * `direction_var` (`string`)\cr see `direction_var` for more details.+ #' rsp = "rsp", |
||
| 31 | +297 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' arm = "ARM", |
||
| 32 | +298 |
- #'+ #' subgroups = c("SEX", "BMRKR2"),
|
||
| 33 | +299 |
- #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade_worsen"))``
+ #' strata = c("STRATA1", "STRATA2")
|
||
| 34 | +300 |
- #'+ #' ), |
||
| 35 | +301 |
- #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] which are used within+ #' data = adrs_f |
||
| 36 | +302 |
- #' [s_count_abnormal_lab_worsen_by_baseline()] to process input data.+ #' ) |
||
| 37 | +303 |
#' |
||
| 38 | -- |
- #' @name abnormal_by_worst_grade_worsen- |
- ||
| 39 | +304 |
- #' @order 1+ #' # Define groupings of BMRKR2 levels. |
||
| 40 | +305 |
- NULL+ #' h_odds_ratio_subgroups_df( |
||
| 41 | +306 |
-
+ #' variables = list( |
||
| 42 | +307 |
- #' Helper function to prepare ADLB with worst labs+ #' rsp = "rsp", |
||
| 43 | +308 |
- #'+ #' arm = "ARM", |
||
| 44 | +309 |
- #' @description `r lifecycle::badge("stable")`
+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 45 | +310 |
- #'+ #' ), |
||
| 46 | +311 |
- #' Helper function to prepare a `df` for generate the patient count shift table.+ #' data = adrs_f, |
||
| 47 | +312 |
- #'+ #' groups_lists = list( |
||
| 48 | +313 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ #' BMRKR2 = list( |
||
| 49 | +314 |
- #' @param worst_flag_low (named `vector`)\cr worst low post-baseline lab grade flag variable. See how this is+ #' "low" = "LOW", |
||
| 50 | +315 |
- #' implemented in the following examples.+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 51 | +316 |
- #' @param worst_flag_high (named `vector`)\cr worst high post-baseline lab grade flag variable. See how this is+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 52 | +317 |
- #' implemented in the following examples.+ #' ) |
||
| 53 | +318 |
- #' @param direction_var (`string`)\cr name of the direction variable specifying the direction of the shift table of+ #' ) |
||
| 54 | +319 |
- #' interest. Only lab records flagged by `L`, `H` or `B` are included in the shift table.+ #' ) |
||
| 55 | +320 |
- #' * `L`: low direction only+ #' |
||
| 56 | +321 |
- #' * `H`: high direction only+ #' @export |
||
| 57 | +322 |
- #' * `B`: both low and high directions+ h_odds_ratio_subgroups_df <- function(variables, |
||
| 58 | +323 |
- #'+ data, |
||
| 59 | +324 |
- #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the+ groups_lists = list(), |
||
| 60 | +325 |
- #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the+ conf_level = 0.95, |
||
| 61 | +326 |
- #' direction specified according to `direction_var`. For instance, for a lab that is+ method = NULL, |
||
| 62 | +327 |
- #' needed for the low direction only, only records flagged by `worst_flag_low` are+ label_all = "All Patients") {
|
||
| 63 | -+ | |||
| 328 | +18x |
- #' selected. For a lab that is needed for both low and high directions, the worst+ if ("strat" %in% names(variables)) {
|
||
| 64 | -+ | |||
| 329 | +! |
- #' low records are selected for the low direction, and the worst high record are selected+ warning( |
||
| 65 | -+ | |||
| 330 | +! |
- #' for the high direction.+ "Warning: the `strat` element name of the `variables` list argument to `h_odds_ratio_subgroups_df() ", |
||
| 66 | -+ | |||
| 331 | +! |
- #'+ "was deprecated in tern 0.9.4.\n ", |
||
| 67 | -+ | |||
| 332 | +! |
- #' @seealso [abnormal_by_worst_grade_worsen]+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 68 | +333 |
- #'+ ) |
||
| 69 | -+ | |||
| 334 | +! |
- #' @examples+ variables[["strata"]] <- variables[["strat"]] |
||
| 70 | +335 |
- #' library(dplyr)+ } |
||
| 71 | +336 |
- #'+ |
||
| 72 | -+ | |||
| 337 | +18x |
- #' # The direction variable, GRADDR, is based on metadata+ checkmate::assert_character(variables$rsp) |
||
| 73 | -+ | |||
| 338 | +18x |
- #' adlb <- tern_ex_adlb %>%+ checkmate::assert_character(variables$arm) |
||
| 74 | -+ | |||
| 339 | +18x |
- #' mutate(+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 75 | -+ | |||
| 340 | +18x |
- #' GRADDR = case_when(+ checkmate::assert_character(variables$strata, null.ok = TRUE) |
||
| 76 | -+ | |||
| 341 | +18x |
- #' PARAMCD == "ALT" ~ "B",+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
||
| 77 | -+ | |||
| 342 | +18x |
- #' PARAMCD == "CRP" ~ "L",+ assert_df_with_variables(data, variables) |
||
| 78 | -+ | |||
| 343 | +18x |
- #' PARAMCD == "IGA" ~ "H"+ checkmate::assert_string(label_all) |
||
| 79 | +344 |
- #' )+ |
||
| 80 | -+ | |||
| 345 | +18x |
- #' ) %>%+ strata_data <- if (is.null(variables$strata)) {
|
||
| 81 | -+ | |||
| 346 | +16x |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ NULL |
||
| 82 | +347 |
- #'+ } else {
|
||
| 83 | -+ | |||
| 348 | +2x |
- #' df <- h_adlb_worsen(+ data[, variables$strata, drop = FALSE] |
||
| 84 | +349 |
- #' adlb,+ } |
||
| 85 | +350 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+
|
||
| 86 | +351 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ # Add All Patients. |
||
| 87 | -+ | |||
| 352 | +18x |
- #' direction_var = "GRADDR"+ result_all <- h_odds_ratio_df( |
||
| 88 | -+ | |||
| 353 | +18x |
- #' )+ rsp = data[[variables$rsp]], |
||
| 89 | -+ | |||
| 354 | +18x |
- #'+ arm = data[[variables$arm]], |
||
| 90 | -+ | |||
| 355 | +18x |
- #' @export+ strata_data = strata_data, |
||
| 91 | -+ | |||
| 356 | +18x |
- h_adlb_worsen <- function(adlb,+ conf_level = conf_level, |
||
| 92 | -+ | |||
| 357 | +18x |
- worst_flag_low = NULL,+ method = method |
||
| 93 | +358 |
- worst_flag_high = NULL,+ ) |
||
| 94 | -+ | |||
| 359 | +18x |
- direction_var) {
+ result_all$subgroup <- label_all |
||
| 95 | -5x | +360 | +18x |
- checkmate::assert_string(direction_var)+ result_all$var <- "ALL" |
| 96 | -5x | +361 | +18x |
- checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
+ result_all$var_label <- label_all |
| 97 | -5x | +362 | +18x |
- assert_df_with_variables(adlb, list("Col" = direction_var))
+ result_all$row_type <- "content" |
| 98 | +363 | |||
| 99 | -5x | +364 | +18x |
- if (any(unique(adlb[[direction_var]]) == "H")) {
+ if (is.null(variables$subgroups)) {
|
| 100 | -4x | +365 | +3x |
- assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
+ result_all |
| 101 | +366 |
- }+ } else {
+ |
+ ||
| 367 | +15x | +
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 102 | +368 | |||
| 103 | -5x | +369 | +15x |
- if (any(unique(adlb[[direction_var]]) == "L")) {
+ l_result <- lapply(l_data, function(grp) {
|
| 104 | -4x | +370 | +62x |
- assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
+ grp_strata_data <- if (is.null(variables$strata)) {
|
| 105 | -+ | |||
| 371 | +54x |
- }+ NULL |
||
| 106 | +372 |
-
+ } else {
|
||
| 107 | -5x | +373 | +8x |
- if (any(unique(adlb[[direction_var]]) == "B")) {
+ grp$df[, variables$strata, drop = FALSE] |
| 108 | -3x | +|||
| 374 | +
- assert_df_with_variables(+ } |
|||
| 109 | -3x | +|||
| 375 | +
- adlb,+ |
|||
| 110 | -3x | +376 | +62x |
- list(+ result <- h_odds_ratio_df( |
| 111 | -3x | -
- "Low" = names(worst_flag_low),- |
- ||
| 112 | -3x | -
- "High" = names(worst_flag_high)- |
- ||
| 113 | -- |
- )- |
- ||
| 114 | -- |
- )- |
- ||
| 115 | -- |
- }- |
- ||
| 116 | -- | - - | -||
| 117 | -+ | 377 | +62x |
- # extract patients with worst post-baseline lab, either low or high or both+ rsp = grp$df[[variables$rsp]], |
| 118 | -5x | +378 | +62x |
- worst_flag <- c(worst_flag_low, worst_flag_high)+ arm = grp$df[[variables$arm]], |
| 119 | -5x | +379 | +62x |
- col_names <- names(worst_flag)+ strata_data = grp_strata_data, |
| 120 | -5x | +380 | +62x |
- filter_values <- worst_flag+ conf_level = conf_level, |
| 121 | -5x | +381 | +62x |
- temp <- Map(+ method = method |
| 122 | -5x | +|||
| 382 | +
- function(x, y) which(adlb[[x]] == y),+ ) |
|||
| 123 | -5x | +383 | +62x |
- col_names,+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 124 | -5x | +384 | +62x |
- filter_values+ cbind(result, result_labels) |
| 125 | +385 |
- )- |
- ||
| 126 | -5x | -
- position_satisfy_filters <- Reduce(union, temp)+ }) |
||
| 127 | +386 | |||
| 128 | -+ | |||
| 387 | +15x |
- # select variables of interest+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 129 | -5x | +388 | +15x |
- adlb_f <- adlb[position_satisfy_filters, ]+ result_subgroups$row_type <- "analysis" |
| 130 | +389 | |||
| 131 | -- |
- # generate subsets for different directionality- |
- ||
| 132 | -5x | +390 | +15x |
- adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]+ rbind( |
| 133 | -5x | +391 | +15x |
- adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]+ result_all, |
| 134 | -5x | +392 | +15x |
- adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]+ result_subgroups |
| 135 | +393 |
-
+ ) |
||
| 136 | +394 |
- # for labs requiring both high and low, data is duplicated and will be stacked on top of each other- |
- ||
| 137 | -5x | -
- adlb_f_b_h <- adlb_f_b- |
- ||
| 138 | -5x | -
- adlb_f_b_l <- adlb_f_b+ } |
||
| 139 | +395 |
-
+ } |
| 140 | +1 |
- # extract data with worst lab- |
- ||
| 141 | -5x | -
- if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
+ #' Proportion difference estimation |
||
| 142 | +2 |
- # change H to High, L to Low- |
- ||
| 143 | -3x | -
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
- |
- ||
| 144 | -3x | -
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ #' |
||
| 145 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 146 | +4 |
- # change, B to High and Low- |
- ||
| 147 | -3x | -
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
- |
- ||
| 148 | -3x | -
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ #' |
||
| 149 | +5 | - - | -||
| 150 | -3x | -
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]- |
- ||
| 151 | -3x | -
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]- |
- ||
| 152 | -3x | -
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]- |
- ||
| 153 | -3x | -
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' The analysis function [estimate_proportion_diff()] creates a layout element to estimate the difference in proportion |
||
| 154 | +6 | - - | -||
| 155 | -3x | -
- out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)- |
- ||
| 156 | -2x | -
- } else if (!is.null(worst_flag_high)) {
- |
- ||
| 157 | -1x | -
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
- |
- ||
| 158 | -1x | -
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ #' of responders within a studied population. The primary analysis variable, `vars`, is a logical variable indicating |
||
| 159 | +7 | - - | -||
| 160 | -1x | -
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]- |
- ||
| 161 | -1x | -
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ #' whether a response has occurred for each record. See the `method` parameter for options of methods to use when |
||
| 162 | +8 | - - | -||
| 163 | -1x | -
- out <- rbind(adlb_out_h, adlb_out_b_h)- |
- ||
| 164 | -1x | -
- } else if (!is.null(worst_flag_low)) {
- |
- ||
| 165 | -1x | -
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
- |
- ||
| 166 | -1x | -
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ #' constructing the confidence interval of the proportion difference. A stratification variable can be supplied via the |
||
| 167 | +9 | - - | -||
| 168 | -1x | -
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]- |
- ||
| 169 | -1x | -
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' `strata` element of the `variables` argument. |
||
| 170 | +10 | - - | -||
| 171 | -1x | -
- out <- rbind(adlb_out_l, adlb_out_b_l)+ #' |
||
| 172 | +11 |
- }+ #' |
||
| 173 | +12 |
-
+ #' @inheritParams prop_diff_strat_nc |
||
| 174 | +13 |
- # label- |
- ||
| 175 | -5x | -
- formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)+ #' @inheritParams argument_convention |
||
| 176 | +14 |
- # NA- |
- ||
| 177 | -5x | -
- out+ #' @param method (`string`)\cr the method used for the confidence interval estimation. |
||
| 178 | +15 |
- }+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 179 | +16 |
-
+ #' |
||
| 180 | +17 |
- #' Helper function to analyze patients for `s_count_abnormal_lab_worsen_by_baseline()`+ #' Options are: ``r shQuote(get_stats("estimate_proportion_diff"))``
|
||
| 181 | +18 |
#' |
||
| 182 | +19 |
- #' @description `r lifecycle::badge("stable")`
+ #' @seealso [d_proportion_diff()] |
||
| 183 | +20 |
#' |
||
| 184 | -- |
- #' Helper function to count the number of patients and the fraction of patients according to- |
- ||
| 185 | +21 |
- #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,+ #' @name prop_diff |
||
| 186 | +22 |
- #' and the direction of interest specified in `direction_var`.+ #' @order 1 |
||
| 187 | +23 |
- #'+ NULL |
||
| 188 | +24 |
- #' @inheritParams argument_convention+ |
||
| 189 | +25 |
- #' @inheritParams h_adlb_worsen+ #' @describeIn prop_diff Statistics function estimating the difference |
||
| 190 | +26 |
- #' @param baseline_var (`string`)\cr name of the baseline lab grade variable.+ #' in terms of responder proportion. |
||
| 191 | +27 |
#' |
||
| 192 | +28 |
- #' @return The counts and fraction of patients+ #' @return |
||
| 193 | +29 |
- #' whose worst post-baseline lab grades are worse than their baseline grades, for+ #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`. |
||
| 194 | +30 |
- #' post-baseline worst grades "1", "2", "3", "4" and "Any".+ #' |
||
| 195 | +31 |
- #'+ #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are |
||
| 196 | +32 |
- #' @seealso [abnormal_by_worst_grade_worsen]+ #' not permitted. |
||
| 197 | +33 |
#' |
||
| 198 | +34 |
#' @examples |
||
| 199 | +35 |
- #' library(dplyr)+ #' s_proportion_diff( |
||
| 200 | +36 |
- #'+ #' df = subset(dta, grp == "A"), |
||
| 201 | +37 |
- #' # The direction variable, GRADDR, is based on metadata+ #' .var = "rsp", |
||
| 202 | +38 |
- #' adlb <- tern_ex_adlb %>%+ #' .ref_group = subset(dta, grp == "B"), |
||
| 203 | +39 |
- #' mutate(+ #' .in_ref_col = FALSE, |
||
| 204 | +40 |
- #' GRADDR = case_when(+ #' conf_level = 0.90, |
||
| 205 | +41 |
- #' PARAMCD == "ALT" ~ "B",+ #' method = "ha" |
||
| 206 | +42 |
- #' PARAMCD == "CRP" ~ "L",+ #' ) |
||
| 207 | +43 |
- #' PARAMCD == "IGA" ~ "H"+ #' |
||
| 208 | +44 |
- #' )+ #' # CMH example with strata |
||
| 209 | +45 |
- #' ) %>%+ #' s_proportion_diff( |
||
| 210 | +46 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' df = subset(dta, grp == "A"), |
||
| 211 | +47 |
- #'+ #' .var = "rsp", |
||
| 212 | +48 |
- #' df <- h_adlb_worsen(+ #' .ref_group = subset(dta, grp == "B"), |
||
| 213 | +49 |
- #' adlb,+ #' .in_ref_col = FALSE, |
||
| 214 | +50 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' variables = list(strata = c("f1", "f2")),
|
||
| 215 | +51 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' conf_level = 0.90, |
||
| 216 | +52 |
- #' direction_var = "GRADDR"+ #' method = "cmh" |
||
| 217 | +53 |
#' ) |
||
| 218 | +54 |
#' |
||
| 219 | +55 |
- #' # `h_worsen_counter`+ #' @export |
||
| 220 | +56 |
- #' h_worsen_counter(+ s_proportion_diff <- function(df, |
||
| 221 | +57 |
- #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),+ .var, |
||
| 222 | +58 |
- #' id = "USUBJID",+ .ref_group, |
||
| 223 | +59 |
- #' .var = "ATOXGR",+ .in_ref_col, |
||
| 224 | +60 |
- #' baseline_var = "BTOXGR",+ variables = list(strata = NULL), |
||
| 225 | +61 |
- #' direction_var = "GRADDR"+ conf_level = 0.95, |
||
| 226 | +62 |
- #' )+ method = c( |
||
| 227 | +63 |
- #'+ "waldcc", "wald", "cmh", |
||
| 228 | +64 |
- #' @export+ "ha", "newcombe", "newcombecc", |
||
| 229 | +65 |
- h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
+ "strat_newcombe", "strat_newcombecc" |
||
| 230 | -17x | +|||
| 66 | +
- checkmate::assert_string(id)+ ), |
|||
| 231 | -17x | +|||
| 67 | +
- checkmate::assert_string(.var)+ weights_method = "cmh") {
|
|||
| 232 | -17x | +68 | +2x |
- checkmate::assert_string(baseline_var)+ method <- match.arg(method) |
| 233 | -17x | +69 | +2x |
- checkmate::assert_scalar(unique(df[[direction_var]]))+ if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
|
| 234 | -17x | +|||
| 70 | +! |
- checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
+ stop(paste( |
||
| 235 | -17x | +|||
| 71 | +! |
- assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))+ "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",+ |
+ ||
| 72 | +! | +
+ "permitted. Please choose a different method." |
||
| 236 | +73 |
-
+ )) |
||
| 237 | +74 |
- # remove post-baseline missing+ } |
||
| 238 | -17x | +75 | +2x |
- df <- df[df[[.var]] != "<Missing>", ]+ y <- list(diff = "", diff_ci = "") |
| 239 | +76 | |||
| 240 | -- |
- # obtain directionality- |
- ||
| 241 | -17x | +77 | +2x |
- direction <- unique(df[[direction_var]])+ if (!.in_ref_col) {
|
| 242 | -+ | |||
| 78 | +2x |
-
+ rsp <- c(.ref_group[[.var]], df[[.var]]) |
||
| 243 | -17x | +79 | +2x |
- if (direction == "Low") {
+ grp <- factor( |
| 244 | -10x | +80 | +2x |
- grade <- -1:-4+ rep( |
| 245 | -10x | +81 | +2x |
- worst_grade <- -4+ c("ref", "Not-ref"),
|
| 246 | -7x | +82 | +2x |
- } else if (direction == "High") {
+ c(nrow(.ref_group), nrow(df)) |
| 247 | -7x | +|||
| 83 | +
- grade <- 1:4+ ), |
|||
| 248 | -7x | +84 | +2x |
- worst_grade <- 4+ levels = c("ref", "Not-ref")
|
| 249 | +85 |
- }+ ) |
||
| 250 | +86 | |||
| 251 | -17x | +87 | +2x |
- if (nrow(df) > 0) {
+ if (!is.null(variables$strata)) {
|
| 252 | -17x | +88 | +1x |
- by_grade <- lapply(grade, function(i) {
+ strata_colnames <- variables$strata |
| 253 | -+ | |||
| 89 | +1x |
- # filter baseline values that is less than i or <Missing>+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
||
| 254 | -68x | +90 | +1x |
- df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
| 255 | +91 |
- # num: number of patients with post-baseline worst lab equal to i+ |
||
| 256 | -68x | +92 | +1x |
- num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))+ assert_df_with_variables(df, strata_vars)+ |
+
| 93 | +1x | +
+ assert_df_with_variables(.ref_group, strata_vars) |
||
| 257 | +94 |
- # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction+ |
||
| 258 | -68x | +|||
| 95 | +
- denom <- length(unique(df_temp[[id]]))+ # Merging interaction strata for reference group rows data and remaining |
|||
| 259 | -68x | +96 | +1x |
- rm(df_temp)+ strata <- c( |
| 260 | -68x | +97 | +1x |
- c(num = num, denom = denom)+ interaction(.ref_group[strata_colnames]), |
| 261 | -+ | |||
| 98 | +1x |
- })+ interaction(df[strata_colnames]) |
||
| 262 | +99 |
- } else {
- |
- ||
| 263 | -! | -
- by_grade <- lapply(1, function(i) {
+ ) |
||
| 264 | -! | +|||
| 100 | +1x |
- c(num = 0, denom = 0)+ strata <- as.factor(strata) |
||
| 265 | +101 |
- })+ } |
||
| 266 | +102 |
- }+ |
||
| 267 | +103 |
-
+ # Defining the std way to calculate weights for strat_newcombe |
||
| 268 | -17x | +104 | +2x |
- names(by_grade) <- as.character(seq_along(by_grade))+ if (!is.null(variables$weights_method)) {
|
| 269 | -+ | |||
| 105 | +! |
-
+ weights_method <- variables$weights_method |
||
| 270 | +106 |
- # baseline grade less 4 or missing+ } else {
|
||
| 271 | -17x | +107 | +2x |
- df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]+ weights_method <- "cmh" |
| 272 | +108 |
-
+ } |
||
| 273 | +109 |
- # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction+ |
||
| 274 | -17x | +110 | +2x |
- denom <- length(unique(df_temp[, id, drop = TRUE]))+ y <- switch(method, |
| 275 | -+ | |||
| 111 | +2x |
-
+ "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE), |
||
| 276 | -+ | |||
| 112 | +2x |
- # condition 1: missing baseline and in the direction of abnormality+ "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE), |
||
| 277 | -17x | +113 | +2x |
- con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)+ "ha" = prop_diff_ha(rsp, grp, conf_level), |
| 278 | -17x | +114 | +2x |
- df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]+ "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE), |
| 279 | -+ | |||
| 115 | +2x |
-
+ "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE), |
||
| 280 | -+ | |||
| 116 | +2x |
- # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline+ "strat_newcombe" = prop_diff_strat_nc(rsp, |
||
| 281 | -17x | +117 | +2x |
- if (direction == "Low") {
+ grp, |
| 282 | -10x | +118 | +2x |
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))+ strata, |
| 283 | -+ | |||
| 119 | +2x |
- } else {
+ weights_method, |
||
| 284 | -7x | +120 | +2x |
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))+ conf_level, |
| 285 | -+ | |||
| 121 | +2x |
- }+ correct = FALSE |
||
| 286 | +122 |
-
+ ), |
||
| 287 | -+ | |||
| 123 | +2x |
- # number of patients satisfy either conditions 1 or 2+ "strat_newcombecc" = prop_diff_strat_nc(rsp, |
||
| 288 | -17x | +124 | +2x |
- num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))+ grp, |
| 289 | -+ | |||
| 125 | +2x |
-
+ strata, |
||
| 290 | -17x | +126 | +2x |
- list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
+ weights_method, |
| 291 | -+ | |||
| 127 | +2x |
- }+ conf_level, |
||
| 292 | -+ | |||
| 128 | +2x |
-
+ correct = TRUE |
||
| 293 | +129 |
- #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline+ ), |
||
| 294 | -+ | |||
| 130 | +2x |
- #' lab grades are worse than their baseline grades.+ "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
|
||
| 295 | +131 |
- #'+ ) |
||
| 296 | +132 |
- #' @return+ |
||
| 297 | -- |
- #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst- |
- ||
| 298 | -- |
- #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades- |
- ||
| 299 | -- |
- #' "1", "2", "3", "4" and "Any".- |
- ||
| 300 | -- |
- #'- |
- ||
| 301 | -- |
- #' @keywords internal- |
- ||
| 302 | -- |
- s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint- |
- ||
| 303 | -- |
- .var = "ATOXGR",- |
- ||
| 304 | -- |
- variables = list(- |
- ||
| 305 | -+ | |||
| 133 | +2x |
- id = "USUBJID",+ y$diff <- y$diff * 100 |
||
| 306 | -+ | |||
| 134 | +2x |
- baseline_var = "BTOXGR",+ y$diff_ci <- y$diff_ci * 100 |
||
| 307 | +135 |
- direction_var = "GRADDR"+ } |
||
| 308 | +136 |
- )) {
- |
- ||
| 309 | -1x | -
- checkmate::assert_string(.var)- |
- ||
| 310 | -1x | -
- checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
+
|
||
| 311 | -1x | +137 | +2x |
- checkmate::assert_string(variables$id)+ attr(y$diff, "label") <- "Difference in Response rate (%)" |
| 312 | -1x | +138 | +2x |
- checkmate::assert_string(variables$baseline_var)+ attr(y$diff_ci, "label") <- d_proportion_diff( |
| 313 | -1x | +139 | +2x |
- checkmate::assert_string(variables$direction_var)+ conf_level, method, |
| 314 | -1x | +140 | +2x |
- assert_df_with_variables(df, c(aval = .var, variables[1:3]))+ long = FALSE |
| 315 | -1x | +|||
| 141 | +
- assert_list_of_variables(variables)+ ) |
|||
| 316 | +142 | |||
| 317 | -1x | +143 | +2x |
- h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)+ y |
| 318 | +144 |
} |
||
| 319 | +145 | |||
| 320 | -- |
- #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun`- |
- ||
| 321 | +146 |
- #' in `count_abnormal_lab_worsen_by_baseline()`.+ #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`. |
||
| 322 | +147 |
#' |
||
| 323 | +148 |
#' @return |
||
| 324 | -- |
- #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with- |
- ||
| 325 | +149 |
- #' formatted [rtables::CellValue()].+ #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 326 | +150 |
#' |
||
| 327 | +151 |
- #' @keywords internal+ #' @examples |
||
| 328 | +152 |
- a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint+ #' a_proportion_diff( |
||
| 329 | +153 |
- s_count_abnormal_lab_worsen_by_baseline,+ #' df = subset(dta, grp == "A"), |
||
| 330 | +154 |
- .formats = c(fraction = format_fraction),+ #' .var = "rsp", |
||
| 331 | +155 |
- .ungroup_stats = "fraction"+ #' .ref_group = subset(dta, grp == "B"), |
||
| 332 | +156 |
- )+ #' .in_ref_col = FALSE, |
||
| 333 | +157 |
-
+ #' conf_level = 0.90, |
||
| 334 | +158 |
- #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function+ #' method = "ha" |
||
| 335 | +159 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' ) |
||
| 336 | +160 |
#' |
||
| 337 | +161 |
- #' @return+ #' @export |
||
| 338 | +162 |
- #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting+ a_proportion_diff <- make_afun( |
||
| 339 | +163 |
- #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted+ s_proportion_diff, |
||
| 340 | +164 |
- #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout.+ .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), |
||
| 341 | +165 |
- #'+ .indent_mods = c(diff = 0L, diff_ci = 1L) |
||
| 342 | +166 |
- #' @examples+ ) |
||
| 343 | +167 |
- #' library(dplyr)+ |
||
| 344 | +168 |
- #'+ #' @describeIn prop_diff Layout-creating function which can take statistics function arguments |
||
| 345 | +169 |
- #' # The direction variable, GRADDR, is based on metadata+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 346 | +170 |
- #' adlb <- tern_ex_adlb %>%+ #' |
||
| 347 | +171 |
- #' mutate(+ #' @return |
||
| 348 | +172 |
- #' GRADDR = case_when(+ #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
||
| 349 | +173 |
- #' PARAMCD == "ALT" ~ "B",+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 350 | +174 |
- #' PARAMCD == "CRP" ~ "L",+ #' the statistics from `s_proportion_diff()` to the table layout. |
||
| 351 | +175 |
- #' PARAMCD == "IGA" ~ "H"+ #' |
||
| 352 | +176 |
- #' )+ #' @examples |
||
| 353 | +177 |
- #' ) %>%+ #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B. |
||
| 354 | +178 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' nex <- 100 # Number of example rows |
||
| 355 | +179 |
- #'+ #' dta <- data.frame( |
||
| 356 | +180 |
- #' df <- h_adlb_worsen(+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
||
| 357 | +181 |
- #' adlb,+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
||
| 358 | +182 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 359 | +183 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
||
| 360 | +184 |
- #' direction_var = "GRADDR"+ #' stringsAsFactors = TRUE |
||
| 361 | +185 |
#' ) |
||
| 362 | +186 |
#' |
||
| 363 | +187 |
- #' basic_table() %>%+ #' l <- basic_table() %>% |
||
| 364 | +188 |
- #' split_cols_by("ARMCD") %>%
+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 365 | +189 |
- #' add_colcounts() %>%+ #' estimate_proportion_diff( |
||
| 366 | +190 |
- #' split_rows_by("PARAMCD") %>%
+ #' vars = "rsp", |
||
| 367 | +191 |
- #' split_rows_by("GRADDR") %>%
+ #' conf_level = 0.90, |
||
| 368 | +192 |
- #' count_abnormal_lab_worsen_by_baseline(+ #' method = "ha" |
||
| 369 | +193 |
- #' var = "ATOXGR",+ #' ) |
||
| 370 | +194 |
- #' variables = list(+ #' |
||
| 371 | +195 |
- #' id = "USUBJID",+ #' build_table(l, df = dta) |
||
| 372 | +196 |
- #' baseline_var = "BTOXGR",+ #' |
||
| 373 | +197 |
- #' direction_var = "GRADDR"+ #' @export |
||
| 374 | +198 |
- #' )+ #' @order 2 |
||
| 375 | +199 |
- #' ) %>%+ estimate_proportion_diff <- function(lyt, |
||
| 376 | +200 |
- #' append_topleft("Direction of Abnormality") %>%
+ vars, |
||
| 377 | +201 |
- #' build_table(df = df, alt_counts_df = tern_ex_adsl)+ variables = list(strata = NULL), |
||
| 378 | +202 |
- #'+ conf_level = 0.95, |
||
| 379 | +203 |
- #' @export+ method = c( |
||
| 380 | +204 |
- #' @order 2+ "waldcc", "wald", "cmh", |
||
| 381 | +205 |
- count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint+ "ha", "newcombe", "newcombecc", |
||
| 382 | +206 |
- var,+ "strat_newcombe", "strat_newcombecc" |
||
| 383 | +207 |
- variables = list(+ ), |
||
| 384 | +208 |
- id = "USUBJID",+ weights_method = "cmh", |
||
| 385 | +209 |
- baseline_var = "BTOXGR",+ na_str = default_na_str(), |
||
| 386 | +210 |
- direction_var = "GRADDR"+ nested = TRUE, |
||
| 387 | +211 |
- ),+ ..., |
||
| 388 | +212 |
- na_str = default_na_str(),+ var_labels = vars, |
||
| 389 | +213 |
- nested = TRUE,+ show_labels = "hidden", |
||
| 390 | +214 |
- ...,+ table_names = vars, |
||
| 391 | +215 |
- table_names = NULL,+ .stats = NULL, |
||
| 392 | +216 |
- .stats = NULL,+ .formats = NULL, |
||
| 393 | +217 |
- .formats = NULL,+ .labels = NULL, |
||
| 394 | +218 |
- .labels = NULL,+ .indent_mods = NULL) {
|
||
| 395 | -+ | |||
| 219 | +4x |
- .indent_mods = NULL) {
+ extra_args <- list( |
||
| 396 | -1x | +220 | +4x |
- checkmate::assert_string(var)+ variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ... |
| 397 | +221 | - - | -||
| 398 | -1x | -
- extra_args <- list(variables = variables, ...)+ ) |
||
| 399 | +222 | |||
| 400 | -1x | +223 | +4x |
afun <- make_afun( |
| 401 | -1x | +224 | +4x |
- a_count_abnormal_lab_worsen_by_baseline,+ a_proportion_diff, |
| 402 | -1x | +225 | +4x |
.stats = .stats, |
| 403 | -1x | +226 | +4x |
.formats = .formats, |
| 404 | -1x | +227 | +4x |
.labels = .labels, |
| 405 | -1x | +228 | +4x |
.indent_mods = .indent_mods |
| 406 | +229 |
) |
||
| 407 | +230 | |||
| 408 | -1x | +231 | +4x |
- lyt <- analyze(+ analyze( |
| 409 | -1x | +232 | +4x |
- lyt = lyt,+ lyt, |
| 410 | -1x | +233 | +4x |
- vars = var,+ vars, |
| 411 | -1x | +234 | +4x |
afun = afun, |
| 412 | -1x | +235 | +4x | +
+ var_labels = var_labels,+ |
+
| 236 | +4x |
na_str = na_str, |
||
| 413 | -1x | +237 | +4x |
nested = nested, |
| 414 | -1x | +238 | +4x |
extra_args = extra_args, |
| 415 | -1x | +239 | +4x |
- show_labels = "hidden"+ show_labels = show_labels, |
| 416 | -+ | |||
| 240 | +4x |
- )+ table_names = table_names |
||
| 417 | +241 | - - | -||
| 418 | -1x | -
- lyt+ ) |
||
| 419 | +242 |
} |
| 1 | +243 |
- #' Additional assertions to use with `checkmate`+ |
||
| 2 | +244 |
- #'+ #' Check proportion difference arguments |
||
| 3 | +245 |
- #' Additional assertion functions which can be used together with the `checkmate` package.+ #' |
||
| 4 | +246 |
- #'+ #' Verifies that and/or convert arguments into valid values to be used in the |
||
| 5 | +247 |
- #' @inheritParams checkmate::assert_factor+ #' estimation of difference in responder proportions. |
||
| 6 | +248 |
- #' @param x (`any`)\cr object to test.+ #' |
||
| 7 | +249 |
- #' @param df (`data.frame`)\cr data set to test.+ #' @inheritParams prop_diff |
||
| 8 | +250 |
- #' @param variables (named `list` of `character`)\cr list of variables to test.+ #' @inheritParams prop_diff_wald |
||
| 9 | +251 |
- #' @param include_boundaries (`flag`)\cr whether to include boundaries when testing+ #' |
||
| 10 | +252 |
- #' for proportions.+ #' @keywords internal |
||
| 11 | +253 |
- #' @param na_level (`string`)\cr the string you have been using to represent NA or+ check_diff_prop_ci <- function(rsp, |
||
| 12 | +254 |
- #' missing data. For `NA` values please consider using directly [is.na()] or+ grp, |
||
| 13 | +255 |
- #' similar approaches.+ strata = NULL, |
||
| 14 | +256 |
- #'+ conf_level, |
||
| 15 | +257 |
- #' @return Nothing if assertion passes, otherwise prints the error message.+ correct = NULL) {
|
||
| 16 | -+ | |||
| 258 | +26x |
- #'+ checkmate::assert_logical(rsp, any.missing = FALSE) |
||
| 17 | -+ | |||
| 259 | +26x |
- #' @name assertions+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
||
| 18 | -+ | |||
| 260 | +26x |
- NULL+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
||
| 19 | -+ | |||
| 261 | +26x |
-
+ checkmate::assert_flag(correct, null.ok = TRUE) |
||
| 20 | +262 |
- check_list_of_variables <- function(x) {
+
|
||
| 21 | -+ | |||
| 263 | +26x |
- # drop NULL elements in list+ if (!is.null(strata)) {
|
||
| 22 | -2957x | +264 | +12x |
- x <- Filter(Negate(is.null), x)+ checkmate::assert_factor(strata, len = length(rsp)) |
| 23 | +265 | - - | -||
| 24 | -2957x | -
- res <- checkmate::check_list(x,+ } |
||
| 25 | -2957x | +|||
| 266 | +
- names = "named",+ |
|||
| 26 | -2957x | +267 | +26x |
- min.len = 1,+ invisible() |
| 27 | -2957x | +|||
| 268 | +
- any.missing = FALSE,+ } |
|||
| 28 | -2957x | +|||
| 269 | +
- types = "character"+ |
|||
| 29 | +270 |
- )+ #' Description of method used for proportion comparison |
||
| 30 | +271 |
- # no empty strings allowed+ #' |
||
| 31 | -2957x | +|||
| 272 | +
- if (isTRUE(res)) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 32 | -2952x | +|||
| 273 | +
- res <- checkmate::check_character(unlist(x), min.chars = 1)+ #' |
|||
| 33 | +274 |
- }+ #' This is an auxiliary function that describes the analysis in |
||
| 34 | -2957x | +|||
| 275 | +
- return(res)+ #' [s_proportion_diff()]. |
|||
| 35 | +276 |
- }+ #' |
||
| 36 | +277 |
- #' @describeIn assertions Checks whether `x` is a valid list of variable names.+ #' @inheritParams s_proportion_diff |
||
| 37 | +278 |
- #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`.+ #' @param long (`flag`)\cr whether a long (`TRUE`) or a short (`FALSE`, default) description is required. |
||
| 38 | +279 |
#' |
||
| 39 | +280 |
- #' @keywords internal+ #' @return A `string` describing the analysis. |
||
| 40 | +281 |
- assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)+ #' |
||
| 41 | +282 |
-
+ #' @seealso [prop_diff] |
||
| 42 | +283 |
- check_df_with_variables <- function(df, variables, na_level = NULL) {
+ #' |
||
| 43 | -2640x | +|||
| 284 | +
- checkmate::assert_data_frame(df)+ #' @export |
|||
| 44 | -2638x | +|||
| 285 | +
- assert_list_of_variables(variables)+ d_proportion_diff <- function(conf_level, |
|||
| 45 | +286 |
-
+ method, |
||
| 46 | +287 |
- # flag for equal variables and column names+ long = FALSE) {
|
||
| 47 | -2636x | +288 | +11x |
- err_flag <- all(unlist(variables) %in% colnames(df))+ label <- paste0(conf_level * 100, "% CI") |
| 48 | -2636x | +289 | +11x |
- checkmate::assert_flag(err_flag)+ if (long) {
|
| 49 | -+ | |||
| 290 | +! |
-
+ label <- paste( |
||
| 50 | -2636x | +|||
| 291 | +! |
- if (isFALSE(err_flag)) {
+ label, |
||
| 51 | -5x | +|||
| 292 | +! |
- vars <- setdiff(unlist(variables), colnames(df))+ ifelse( |
||
| 52 | -5x | +|||
| 293 | +! |
- return(paste(+ method == "cmh", |
||
| 53 | -5x | +|||
| 294 | +! |
- deparse(substitute(df)),+ "for adjusted difference", |
||
| 54 | -5x | +|||
| 295 | +! |
- "does not contain all specified variables as column names. Missing from data frame:",+ "for difference" |
||
| 55 | -5x | +|||
| 296 | +
- paste(vars, collapse = ", ")+ ) |
|||
| 56 | +297 |
- ))+ ) |
||
| 57 | +298 |
} |
||
| 58 | +299 |
- # checking if na_level is present and in which column+ |
||
| 59 | -2631x | +300 | +11x |
- if (!is.null(na_level)) {
+ method_part <- switch(method, |
| 60 | -9x | +301 | +11x |
- checkmate::assert_string(na_level)+ "cmh" = "CMH, without correction", |
| 61 | -9x | +302 | +11x |
- res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))+ "waldcc" = "Wald, with correction", |
| 62 | -9x | +303 | +11x |
- if (any(res)) {
+ "wald" = "Wald, without correction", |
| 63 | -1x | +304 | +11x |
- return(paste0(+ "ha" = "Anderson-Hauck", |
| 64 | -1x | +305 | +11x |
- deparse(substitute(df)), " contains explicit na_level (", na_level,
+ "newcombe" = "Newcombe, without correction", |
| 65 | -1x | +306 | +11x |
- ") in the following columns: ", paste0(unlist(variables)[res],+ "newcombecc" = "Newcombe, with correction", |
| 66 | -1x | +307 | +11x |
- collapse = ", "+ "strat_newcombe" = "Stratified Newcombe, without correction", |
| 67 | -+ | |||
| 308 | +11x |
- )+ "strat_newcombecc" = "Stratified Newcombe, with correction", |
||
| 68 | -+ | |||
| 309 | +11x |
- ))+ stop(paste(method, "does not have a description")) |
||
| 69 | +310 |
- }+ ) |
||
| 70 | -+ | |||
| 311 | +11x |
- }+ paste0(label, " (", method_part, ")")
|
||
| 71 | -2630x | +|||
| 312 | +
- return(TRUE)+ } |
|||
| 72 | +313 |
- }+ |
||
| 73 | +314 |
- #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`.+ #' Helper functions to calculate proportion difference |
||
| 74 | +315 |
- #' Please notice how this produces an error when not all variables are present in the+ #' |
||
| 75 | +316 |
- #' data.frame while the opposite is not required.+ #' @description `r lifecycle::badge("stable")`
|
||
| 76 | +317 |
#' |
||
| 77 | +318 |
- #' @keywords internal+ #' @inheritParams argument_convention |
||
| 78 | +319 |
- assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)+ #' @inheritParams prop_diff |
||
| 79 | +320 |
-
+ #' @param grp (`factor`)\cr vector assigning observations to one out of two groups |
||
| 80 | +321 |
- check_valid_factor <- function(x,+ #' (e.g. reference and treatment group). |
||
| 81 | +322 |
- min.levels = 1, # nolint+ #' |
||
| 82 | +323 |
- max.levels = NULL, # nolint+ #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci` |
||
| 83 | +324 |
- null.ok = TRUE, # nolint+ #' (proportion difference confidence interval). |
||
| 84 | +325 |
- any.missing = TRUE, # nolint+ #' |
||
| 85 | +326 |
- n.levels = NULL, # nolint+ #' @seealso [prop_diff()] for implementation of these helper functions. |
||
| 86 | +327 |
- len = NULL) {
+ #' |
||
| 87 | +328 |
- # checks on levels insertion+ #' @name h_prop_diff |
||
| 88 | -1111x | +|||
| 329 | +
- checkmate::assert_int(min.levels, lower = 1)+ NULL |
|||
| 89 | +330 | |||
| 90 | +331 |
- # main factor check- |
- ||
| 91 | -1111x | -
- res <- checkmate::check_factor(x,- |
- ||
| 92 | -1111x | -
- min.levels = min.levels,- |
- ||
| 93 | -1111x | -
- null.ok = null.ok,- |
- ||
| 94 | -1111x | -
- max.levels = max.levels,- |
- ||
| 95 | -1111x | -
- any.missing = any.missing,- |
- ||
| 96 | -1111x | -
- n.levels = n.levels+ #' @describeIn h_prop_diff The Wald interval follows the usual textbook |
||
| 97 | +332 |
- )+ #' definition for a single proportion confidence interval using the normal |
||
| 98 | +333 |
-
+ #' approximation. It is possible to include a continuity correction for Wald's |
||
| 99 | +334 |
- # no empty strings allowed+ #' interval. |
||
| 100 | -1111x | +|||
| 335 | +
- if (isTRUE(res)) {
+ #' |
|||
| 101 | -1097x | +|||
| 336 | +
- res <- checkmate::check_character(levels(x), min.chars = 1)+ #' @param correct (`flag`)\cr whether to include the continuity correction. For further |
|||
| 102 | +337 |
- }+ #' information, see [stats::prop.test()]. |
||
| 103 | +338 |
-
+ #' |
||
| 104 | -1111x | +|||
| 339 | +
- return(res)+ #' @examples |
|||
| 105 | +340 |
- }+ #' # Wald confidence interval |
||
| 106 | +341 |
- #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty+ #' set.seed(2) |
||
| 107 | +342 |
- #' string levels). Note that `NULL` and `NA` elements are allowed.+ #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20) |
||
| 108 | +343 |
- #'+ #' grp <- factor(c(rep("A", 10), rep("B", 10)))
|
||
| 109 | +344 |
- #' @keywords internal+ #' |
||
| 110 | +345 |
- assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)+ #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE) |
||
| 111 | +346 |
-
+ #' |
||
| 112 | +347 |
- check_df_with_factors <- function(df,+ #' @export |
||
| 113 | +348 |
- variables,+ prop_diff_wald <- function(rsp, |
||
| 114 | +349 |
- min.levels = 1, # nolint+ grp, |
||
| 115 | +350 |
- max.levels = NULL, # nolint+ conf_level = 0.95, |
||
| 116 | +351 |
- any.missing = TRUE, # nolint+ correct = FALSE) {
|
||
| 117 | -+ | |||
| 352 | +8x |
- na_level = NULL) {
+ if (isTRUE(correct)) {
|
||
| 118 | -254x | +353 | +5x |
- res <- check_df_with_variables(df, variables, na_level)+ mthd <- "waldcc" |
| 119 | +354 |
- # checking if all the columns specified by variables are valid factors+ } else {
|
||
| 120 | -253x | +355 | +3x |
- if (isTRUE(res)) {
+ mthd <- "wald" |
| 121 | +356 |
- # searching the data.frame with selected columns (variables) as a list+ } |
||
| 122 | -251x | +357 | +8x |
- res <- lapply(+ grp <- as_factor_keep_attributes(grp) |
| 123 | -251x | +358 | +8x |
- X = as.list(df)[unlist(variables)],+ check_diff_prop_ci( |
| 124 | -251x | +359 | +8x |
- FUN = check_valid_factor,+ rsp = rsp, grp = grp, conf_level = conf_level, correct = correct |
| 125 | -251x | +|||
| 360 | +
- min.levels = min.levels,+ )+ |
+ |||
| 361 | ++ | + + | +||
| 362 | ++ |
+ # check if binary response is coded as logical |
||
| 126 | -251x | +363 | +8x |
- max.levels = max.levels,+ checkmate::assert_logical(rsp, any.missing = FALSE) |
| 127 | -251x | +364 | +8x |
- any.missing = any.missing+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
| 128 | +365 |
- )+ |
||
| 129 | -251x | +366 | +8x |
- res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
| 130 | -251x | +|||
| 367 | +
- if (any(res_lo)) {
+ # x1 and n1 are non-reference groups. |
|||
| 131 | -6x | +368 | +8x |
- return(paste0(+ diff_ci <- desctools_binom( |
| 132 | -6x | +369 | +8x |
- deparse(substitute(df)), " does not contain only factor variables among:",+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
| 133 | -6x | +370 | +8x |
- "\n* Column `", paste0(unlist(variables)[res_lo],+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
| 134 | -6x | +371 | +8x |
- "` of the data.frame -> ", res[res_lo],+ conf.level = conf_level, |
| 135 | -6x | +372 | +8x |
- collapse = "\n* "+ method = mthd |
| 136 | +373 |
- )+ ) |
||
| 137 | +374 |
- ))+ |
||
| 138 | -+ | |||
| 375 | +8x |
- } else {
+ list( |
||
| 139 | -245x | +376 | +8x |
- res <- TRUE+ "diff" = unname(diff_ci[, "est"]), |
| 140 | -+ | |||
| 377 | +8x |
- }+ "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
|
||
| 141 | +378 |
- }- |
- ||
| 142 | -247x | -
- return(res)+ ) |
||
| 143 | +379 |
} |
||
| 144 | +380 | |||
| 145 | -- |
- #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`- |
- ||
| 146 | +381 |
- #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ #' @describeIn h_prop_diff Anderson-Hauck confidence interval. |
||
| 147 | +382 |
- #' trim `NA` levels out of the vector list itself.+ #' |
||
| 148 | +383 |
- #'+ #' @examples |
||
| 149 | +384 |
- #' @keywords internal+ #' # Anderson-Hauck confidence interval |
||
| 150 | +385 |
- assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)+ #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B. |
||
| 151 | +386 |
-
+ #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE) |
||
| 152 | +387 |
- #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.+ #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
|
||
| 153 | +388 |
#' |
||
| 154 | +389 |
- #' @keywords internal+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90) |
||
| 155 | +390 |
- assert_proportion_value <- function(x, include_boundaries = FALSE) {
- |
- ||
| 156 | -14412x | -
- checkmate::assert_number(x, lower = 0, upper = 1)- |
- ||
| 157 | -14400x | -
- checkmate::assert_flag(include_boundaries)- |
- ||
| 158 | -14400x | -
- if (isFALSE(include_boundaries)) {
- |
- ||
| 159 | -8610x | -
- checkmate::assert_true(x > 0)- |
- ||
| 160 | -8608x | -
- checkmate::assert_true(x < 1)+ #' |
||
| 161 | +391 |
- }+ #' ## Edge case: Same proportion of response in A and B. |
||
| 162 | +392 |
- }+ #' rsp <- c(TRUE, FALSE, TRUE, FALSE) |
| 1 | +393 |
- #' Occurrence table sorting+ #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 2 | +394 |
#' |
||
| 3 | +395 |
- #' @description `r lifecycle::badge("stable")`
+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6) |
||
| 4 | +396 |
#' |
||
| 5 | +397 |
- #' Functions to score occurrence table subtables and rows which can be used in the+ #' @export |
||
| 6 | +398 |
- #' sorting of occurrence tables.+ prop_diff_ha <- function(rsp, |
||
| 7 | +399 |
- #'+ grp, |
||
| 8 | +400 |
- #' @name score_occurrences+ conf_level) {
|
||
| 9 | -+ | |||
| 401 | +4x |
- NULL+ grp <- as_factor_keep_attributes(grp)+ |
+ ||
| 402 | +4x | +
+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
||
| 10 | +403 | |||
| 11 | -+ | |||
| 404 | +4x |
- #' @describeIn score_occurrences Scoring function which sums the counts across all+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
||
| 12 | +405 |
- #' columns. It will fail if anything else but counts are used.+ # x1 and n1 are non-reference groups. |
||
| 13 | -+ | |||
| 406 | +4x |
- #'+ ci <- desctools_binom( |
||
| 14 | -+ | |||
| 407 | +4x |
- #' @inheritParams rtables_access+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
||
| 15 | -+ | |||
| 408 | +4x |
- #'+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
||
| 16 | -+ | |||
| 409 | +4x |
- #' @return+ conf.level = conf_level, |
||
| 17 | -+ | |||
| 410 | +4x |
- #' * `score_occurrences()` returns the sum of counts across all columns of a table row.+ method = "ha" |
||
| 18 | +411 |
- #'+ ) |
||
| 19 | -+ | |||
| 412 | +4x |
- #' @seealso [h_row_first_values()]+ list( |
||
| 20 | -+ | |||
| 413 | +4x |
- #'+ "diff" = unname(ci[, "est"]), |
||
| 21 | -+ | |||
| 414 | +4x |
- #' @examples+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
||
| 22 | +415 |
- #' lyt <- basic_table() %>%+ ) |
||
| 23 | +416 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 24 | +417 |
- #' add_colcounts() %>%+ |
||
| 25 | +418 |
- #' analyze_num_patients(+ #' @describeIn h_prop_diff Newcombe confidence interval. It is based on |
||
| 26 | +419 |
- #' vars = "USUBJID",+ #' the Wilson score confidence interval for a single binomial proportion. |
||
| 27 | +420 |
- #' .stats = c("unique"),
+ #' |
||
| 28 | +421 |
- #' .labels = c("Total number of patients with at least one event")
+ #' @examples |
||
| 29 | +422 |
- #' ) %>%+ #' # Newcombe confidence interval |
||
| 30 | +423 |
- #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
+ #' |
||
| 31 | +424 |
- #' summarize_num_patients(+ #' set.seed(1) |
||
| 32 | +425 |
- #' var = "USUBJID",+ #' rsp <- c( |
||
| 33 | +426 |
- #' .stats = c("unique", "nonunique"),
+ #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE), |
||
| 34 | +427 |
- #' .labels = c(+ #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE) |
||
| 35 | +428 |
- #' "Total number of patients with at least one event",+ #' ) |
||
| 36 | +429 |
- #' "Total number of events"+ #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
|
||
| 37 | +430 |
- #' )+ #' table(rsp, grp) |
||
| 38 | +431 |
- #' ) %>%+ #' |
||
| 39 | +432 |
- #' count_occurrences(vars = "AEDECOD")+ #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9) |
||
| 40 | +433 |
#' |
||
| 41 | +434 |
- #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>%+ #' @export |
||
| 42 | +435 |
- #' prune_table()+ prop_diff_nc <- function(rsp, |
||
| 43 | +436 |
- #'+ grp, |
||
| 44 | +437 |
- #' tbl_sorted <- tbl %>%+ conf_level, |
||
| 45 | +438 |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
+ correct = FALSE) {
|
||
| 46 | -+ | |||
| 439 | +2x |
- #'+ if (isTRUE(correct)) {
|
||
| 47 | -+ | |||
| 440 | +! |
- #' tbl_sorted+ mthd <- "scorecc" |
||
| 48 | +441 |
- #'+ } else {
|
||
| 49 | -+ | |||
| 442 | +2x |
- #' @export+ mthd <- "score" |
||
| 50 | +443 |
- score_occurrences <- function(table_row) {
+ } |
||
| 51 | -37x | +444 | +2x |
- row_counts <- h_row_counts(table_row)+ grp <- as_factor_keep_attributes(grp) |
| 52 | -37x | -
- sum(row_counts)- |
- ||
| 53 | -+ | 445 | +2x |
- }+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
| 54 | +446 | |||
| 55 | -+ | |||
| 447 | +2x |
- #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include+ p_grp <- tapply(rsp, grp, mean) |
||
| 56 | -+ | |||
| 448 | +2x |
- #' specific columns in the scoring. See [h_row_counts()] for further information.+ diff_p <- unname(diff(p_grp)) |
||
| 57 | -+ | |||
| 449 | +2x |
- #'+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
||
| 58 | -+ | |||
| 450 | +2x |
- #' @inheritParams has_count_in_cols+ ci <- desctools_binom( |
||
| 59 | +451 |
- #'+ # x1 and n1 are non-reference groups. |
||
| 60 | -+ | |||
| 452 | +2x |
- #' @return+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
||
| 61 | -+ | |||
| 453 | +2x |
- #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
||
| 62 | -+ | |||
| 454 | +2x |
- #' of a table row.+ conf.level = conf_level, |
||
| 63 | -+ | |||
| 455 | +2x |
- #'+ method = mthd |
||
| 64 | +456 |
- #' @seealso [h_row_counts()]+ ) |
||
| 65 | -+ | |||
| 457 | +2x |
- #'+ list( |
||
| 66 | -+ | |||
| 458 | +2x |
- #' @examples+ "diff" = unname(ci[, "est"]), |
||
| 67 | -+ | |||
| 459 | +2x |
- #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
||
| 68 | +460 |
- #'+ ) |
||
| 69 | +461 |
- #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted.+ } |
||
| 70 | +462 |
- #' # That would require a second pass of `sort_at_path`.+ |
||
| 71 | +463 |
- #' tbl_sorted <- tbl %>%+ #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in |
||
| 72 | +464 |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
+ #' response rates between the experimental treatment group and the control treatment group, adjusted |
||
| 73 | +465 |
- #'+ #' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights. For the CMH chi-squared |
||
| 74 | +466 |
- #' tbl_sorted+ #' test, use [stats::mantelhaen.test()]. |
||
| 75 | +467 |
#' |
||
| 76 | -- |
- #' @export- |
- ||
| 77 | +468 |
- score_occurrences_cols <- function(...) {
- |
- ||
| 78 | -4x | -
- function(table_row) {
- |
- ||
| 79 | -20x | -
- row_counts <- h_row_counts(table_row, ...)- |
- ||
| 80 | -20x | -
- sum(row_counts)+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 81 | +469 |
- }+ #' |
||
| 82 | +470 |
- }+ #' @examples |
||
| 83 | +471 |
-
+ #' # Cochran-Mantel-Haenszel confidence interval |
||
| 84 | +472 |
- #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on+ #' |
||
| 85 | +473 |
- #' subtables: They sum up all specified column counts in the subtable. This is useful when+ #' set.seed(2) |
||
| 86 | +474 |
- #' there is no available content row summing up these counts.+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
||
| 87 | +475 |
- #'+ #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
|
||
| 88 | +476 |
- #' @return+ #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
|
||
| 89 | +477 |
- #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable+ #' strata_data <- data.frame( |
||
| 90 | +478 |
- #' across all specified columns.+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 91 | +479 |
- #'+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 92 | +480 |
- #' @examples+ #' stringsAsFactors = TRUE |
||
| 93 | +481 |
- #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl))+ #' ) |
||
| 94 | +482 |
#' |
||
| 95 | +483 |
- #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That+ #' prop_diff_cmh( |
||
| 96 | +484 |
- #' # would require a second pass of `sort_at_path`.+ #' rsp = rsp, grp = grp, strata = interaction(strata_data), |
||
| 97 | +485 |
- #' tbl_sorted <- tbl %>%+ #' conf_level = 0.90 |
||
| 98 | +486 |
- #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
+ #' ) |
||
| 99 | +487 |
#' |
||
| 100 | +488 |
- #' tbl_sorted+ #' @export |
||
| 101 | +489 |
- #'+ prop_diff_cmh <- function(rsp, |
||
| 102 | +490 |
- #' @export+ grp, |
||
| 103 | +491 |
- score_occurrences_subtable <- function(...) {
+ strata, |
||
| 104 | -1x | +|||
| 492 | +
- score_table_row <- score_occurrences_cols(...)+ conf_level = 0.95) {
|
|||
| 105 | -1x | +493 | +8x |
- function(table_tree) {
+ grp <- as_factor_keep_attributes(grp) |
| 106 | -2x | +494 | +8x |
- table_rows <- collect_leaves(table_tree)+ strata <- as_factor_keep_attributes(strata) |
| 107 | -2x | +495 | +8x |
- counts <- vapply(table_rows, score_table_row, numeric(1))+ check_diff_prop_ci( |
| 108 | -2x | -
- sum(counts)- |
- ||
| 109 | -+ | 496 | +8x |
- }+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
| 110 | +497 |
- }+ ) |
||
| 111 | +498 | |||
| 112 | -+ | |||
| 499 | +8x |
- #' @describeIn score_occurrences Produces a score function for sorting table by summing the first content row in+ if (any(tapply(rsp, strata, length) < 5)) {
|
||
| 113 | -+ | |||
| 500 | +1x |
- #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()].+ warning("Less than 5 observations in some strata.")
|
||
| 114 | +501 |
- #'+ } |
||
| 115 | +502 |
- #' @return+ |
||
| 116 | +503 |
- #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in+ # first dimension: FALSE, TRUE |
||
| 117 | +504 |
- #' specified columns.+ # 2nd dimension: CONTROL, TX |
||
| 118 | +505 |
- #'+ # 3rd dimension: levels of strata |
||
| 119 | +506 |
- #' @export+ # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records |
||
| 120 | -+ | |||
| 507 | +8x |
- score_occurrences_cont_cols <- function(...) {
+ t_tbl <- table( |
||
| 121 | -1x | +508 | +8x |
- score_table_row <- score_occurrences_cols(...)+ factor(rsp, levels = c("FALSE", "TRUE")),
|
| 122 | -1x | +509 | +8x |
- function(table_tree) {
+ grp, |
| 123 | -2x | -
- if (inherits(table_tree, "ContentRow")) {
- |
- ||
| 124 | -! | +510 | +8x |
- return(NA)+ strata |
| 125 | +511 |
- }+ ) |
||
| 126 | -2x | +512 | +8x |
- content_row <- h_content_first_row(table_tree)+ n1 <- colSums(t_tbl[1:2, 1, ]) |
| 127 | -2x | +513 | +8x |
- score_table_row(content_row)+ n2 <- colSums(t_tbl[1:2, 2, ]) |
| 128 | -+ | |||
| 514 | +8x |
- }+ p1 <- t_tbl[2, 1, ] / n1 |
||
| 129 | -+ | |||
| 515 | +8x |
- }+ p2 <- t_tbl[2, 2, ] / n2 |
| 1 | +516 |
- #' Custom split functions+ # CMH weights |
||
| 2 | -+ | |||
| 517 | +8x |
- #'+ use_stratum <- (n1 > 0) & (n2 > 0) |
||
| 3 | -+ | |||
| 518 | +8x |
- #' @description `r lifecycle::badge("stable")`
+ n1 <- n1[use_stratum] |
||
| 4 | -+ | |||
| 519 | +8x |
- #'+ n2 <- n2[use_stratum] |
||
| 5 | -+ | |||
| 520 | +8x |
- #' Collection of useful functions that are expanding on the core list of functions+ p1 <- p1[use_stratum] |
||
| 6 | -+ | |||
| 521 | +8x |
- #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()]+ p2 <- p2[use_stratum] |
||
| 7 | -+ | |||
| 522 | +8x |
- #' for more information on how to make a custom split function. All these functions+ wt <- (n1 * n2 / (n1 + n2)) |
||
| 8 | -+ | |||
| 523 | +8x |
- #' work with [rtables::split_rows_by()] argument `split_fun` to modify the way the split+ wt_normalized <- wt / sum(wt) |
||
| 9 | -+ | |||
| 524 | +8x |
- #' happens. For other split functions, consider consulting [`rtables::split_funcs`].+ est1 <- sum(wt_normalized * p1) |
||
| 10 | -+ | |||
| 525 | +8x |
- #'+ est2 <- sum(wt_normalized * p2) |
||
| 11 | -+ | |||
| 526 | +8x |
- #' @seealso [rtables::make_split_fun()]+ estimate <- c(est1, est2) |
||
| 12 | -+ | |||
| 527 | +8x |
- #'+ names(estimate) <- levels(grp) |
||
| 13 | -+ | |||
| 528 | +8x |
- #' @name utils_split_funs+ se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1)) |
||
| 14 | -+ | |||
| 529 | +8x |
- NULL+ se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2)) |
||
| 15 | -+ | |||
| 530 | +8x |
-
+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 16 | -+ | |||
| 531 | +8x |
- #' @describeIn utils_split_funs Split function to place reference group facet at a specific position+ err1 <- z * se1 |
||
| 17 | -+ | |||
| 532 | +8x |
- #' during post-processing stage.+ err2 <- z * se2 |
||
| 18 | -+ | |||
| 533 | +8x |
- #'+ ci1 <- c((est1 - err1), (est1 + err1)) |
||
| 19 | -+ | |||
| 534 | +8x |
- #' @param position (`string` or `integer`)\cr position to use for the reference group facet. Can be `"first"`,+ ci2 <- c((est2 - err2), (est2 + err2)) |
||
| 20 | -+ | |||
| 535 | +8x |
- #' `"last"`, or a specific position.+ estimate_ci <- list(ci1, ci2) |
||
| 21 | -+ | |||
| 536 | +8x |
- #'+ names(estimate_ci) <- levels(grp) |
||
| 22 | -+ | |||
| 537 | +8x |
- #' @return+ diff_est <- est2 - est1 |
||
| 23 | -+ | |||
| 538 | +8x |
- #' * `ref_group_position()` returns an utility function that puts the reference group+ se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2)) |
||
| 24 | -+ | |||
| 539 | +8x |
- #' as first, last or at a certain position and needs to be assigned to `split_fun`.+ diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff) |
||
| 25 | +540 |
- #'+ |
||
| 26 | -+ | |||
| 541 | +8x |
- #' @examples+ list( |
||
| 27 | -+ | |||
| 542 | +8x |
- #' library(dplyr)+ prop = estimate, |
||
| 28 | -+ | |||
| 543 | +8x |
- #'+ prop_ci = estimate_ci, |
||
| 29 | -+ | |||
| 544 | +8x |
- #' dat <- data.frame(+ diff = diff_est, |
||
| 30 | -+ | |||
| 545 | +8x |
- #' x = factor(letters[1:5], levels = letters[5:1]),+ diff_ci = diff_ci, |
||
| 31 | -+ | |||
| 546 | +8x |
- #' y = 1:5+ weights = wt_normalized, |
||
| 32 | -+ | |||
| 547 | +8x |
- #' )+ n1 = n1, |
||
| 33 | -+ | |||
| 548 | +8x |
- #'+ n2 = n2 |
||
| 34 | +549 |
- #' # With rtables layout functions+ ) |
||
| 35 | +550 |
- #' basic_table() %>%+ } |
||
| 36 | +551 |
- #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
+
|
||
| 37 | +552 |
- #' analyze("y") %>%
+ #' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval and difference in response |
||
| 38 | +553 |
- #' build_table(dat)+ #' rates between the experimental treatment group and the control treatment group, adjusted for stratification |
||
| 39 | +554 |
- #'+ #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
|
||
| 40 | +555 |
- #' # With tern layout funcitons+ #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights |
||
| 41 | +556 |
- #' adtte_f <- tern_ex_adtte %>%+ #' (see [prop_diff_cmh()]). |
||
| 42 | +557 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 43 | +558 |
- #' mutate(+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 44 | +559 |
- #' AVAL = day2month(AVAL),+ #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"` |
||
| 45 | +560 |
- #' is_event = CNSR == 0+ #' and directs the way weights are estimated. |
||
| 46 | +561 |
- #' )+ #' |
||
| 47 | +562 |
- #'+ #' @references |
||
| 48 | +563 |
- #' basic_table() %>%+ #' \insertRef{Yan2010-jt}{tern}
|
||
| 49 | +564 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
+ #' |
||
| 50 | +565 |
- #' add_colcounts() %>%+ #' @examples |
||
| 51 | +566 |
- #' surv_time(+ #' # Stratified Newcombe confidence interval |
||
| 52 | +567 |
- #' vars = "AVAL",+ #' |
||
| 53 | +568 |
- #' var_labels = "Survival Time (Months)",+ #' set.seed(2) |
||
| 54 | +569 |
- #' is_event = "is_event",+ #' data_set <- data.frame( |
||
| 55 | +570 |
- #' ) %>%+ #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 56 | +571 |
- #' build_table(df = adtte_f)+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 57 | +572 |
- #'+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 58 | +573 |
- #' basic_table() %>%+ #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
|
||
| 59 | +574 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>%+ #' stringsAsFactors = TRUE |
||
| 60 | +575 |
- #' add_colcounts() %>%+ #' ) |
||
| 61 | +576 |
- #' surv_time(+ #' |
||
| 62 | +577 |
- #' vars = "AVAL",+ #' prop_diff_strat_nc( |
||
| 63 | +578 |
- #' var_labels = "Survival Time (Months)",+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 64 | +579 |
- #' is_event = "is_event",+ #' weights_method = "cmh", |
||
| 65 | +580 |
- #' ) %>%+ #' conf_level = 0.90 |
||
| 66 | +581 |
- #' build_table(df = adtte_f)+ #' ) |
||
| 67 | +582 |
#' |
||
| 68 | +583 |
- #' @export+ #' prop_diff_strat_nc( |
||
| 69 | +584 |
- ref_group_position <- function(position = "first") {
- |
- ||
| 70 | -20x | -
- make_split_fun(- |
- ||
| 71 | -20x | -
- post = list(- |
- ||
| 72 | -20x | -
- function(splret, spl, fulldf) {
- |
- ||
| 73 | -57x | -
- if (!"ref_group_value" %in% methods::slotNames(spl)) {
+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 74 | -1x | +|||
| 585 | +
- stop("Reference group is undefined.")
+ #' weights_method = "wilson_h", |
|||
| 75 | +586 |
- }+ #' conf_level = 0.90 |
||
| 76 | +587 |
-
+ #' ) |
||
| 77 | -56x | +|||
| 588 | +
- spl_var <- rtables:::spl_payload(spl)+ #' |
|||
| 78 | -56x | +|||
| 589 | +
- fulldf[[spl_var]] <- factor(fulldf[[spl_var]])+ #' @export |
|||
| 79 | -56x | +|||
| 590 | +
- init_lvls <- levels(fulldf[[spl_var]])+ prop_diff_strat_nc <- function(rsp, |
|||
| 80 | +591 |
-
+ grp, |
||
| 81 | -56x | +|||
| 592 | +
- if (!all(names(splret$values) %in% init_lvls)) {
+ strata, |
|||
| 82 | -! | +|||
| 593 | +
- stop("This split function does not work with combination facets.")
+ weights_method = c("cmh", "wilson_h"),
|
|||
| 83 | +594 |
- }+ conf_level = 0.95, |
||
| 84 | +595 |
-
+ correct = FALSE) {
|
||
| 85 | -56x | +596 | +4x |
- ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl))+ weights_method <- match.arg(weights_method) |
| 86 | -56x | +597 | +4x |
- pos_choices <- c("first", "last")
+ grp <- as_factor_keep_attributes(grp) |
| 87 | -56x | +598 | +4x |
- if (checkmate::test_choice(position, pos_choices) && position == "first") {
+ strata <- as_factor_keep_attributes(strata) |
| 88 | -41x | +599 | +4x |
- pos <- 0+ check_diff_prop_ci( |
| 89 | -15x | +600 | +4x |
- } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
| 90 | -12x | +|||
| 601 | +
- pos <- length(init_lvls)+ ) |
|||
| 91 | -3x | +602 | +4x |
- } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
| 92 | -3x | +603 | +4x |
- pos <- position - 1+ checkmate::assert_flag(correct) |
| 93 | -+ | |||
| 604 | +4x |
- } else {
+ if (any(tapply(rsp, strata, length) < 5)) {
|
||
| 94 | +605 | ! |
- stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
+ warning("Less than 5 observations in some strata.")
|
|
| 95 | +606 |
- }+ } |
||
| 96 | +607 | |||
| 97 | -56x | +608 | +4x |
- reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos)+ rsp_by_grp <- split(rsp, f = grp) |
| 98 | -56x | +609 | +4x |
- ord <- match(reord_lvls, names(splret$values))+ strata_by_grp <- split(strata, f = grp) |
| 99 | +610 | |||
| 100 | -56x | +|||
| 611 | +
- make_split_result(+ # Finding the weights |
|||
| 101 | -56x | +612 | +4x |
- splret$values[ord],+ weights <- if (identical(weights_method, "cmh")) {
|
| 102 | -56x | +613 | +3x |
- splret$datasplit[ord],+ prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights |
| 103 | -56x | -
- splret$labels[ord]- |
- ||
| 104 | -+ | 614 | +4x |
- )+ } else if (identical(weights_method, "wilson_h")) {
|
| 105 | -+ | |||
| 615 | +1x |
- }+ prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights |
||
| 106 | +616 |
- )+ } |
||
| 107 | -+ | |||
| 617 | +4x |
- )+ weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0 |
||
| 108 | +618 |
- }+ |
||
| 109 | +619 |
-
+ # Calculating lower (`l`) and upper (`u`) confidence bounds per group. |
||
| 110 | -+ | |||
| 620 | +4x |
- #' @describeIn utils_split_funs Split function to change level order based on an `integer`+ strat_wilson_by_grp <- Map( |
||
| 111 | -+ | |||
| 621 | +4x |
- #' vector or a `character` vector that represent the split variable's factor levels.+ prop_strat_wilson, |
||
| 112 | -+ | |||
| 622 | +4x |
- #'+ rsp = rsp_by_grp, |
||
| 113 | -+ | |||
| 623 | +4x |
- #' @param order (`character` or `numeric`)\cr vector of ordering indices for the split facets.+ strata = strata_by_grp, |
||
| 114 | -+ | |||
| 624 | +4x |
- #'+ weights = list(weights, weights), |
||
| 115 | -+ | |||
| 625 | +4x |
- #' @return+ conf_level = conf_level, |
||
| 116 | -+ | |||
| 626 | +4x |
- #' * `level_order()` returns an utility function that changes the original levels' order,+ correct = correct |
||
| 117 | +627 |
- #' depending on input `order` and split levels.+ ) |
||
| 118 | +628 |
- #'+ |
||
| 119 | -+ | |||
| 629 | +4x |
- #' @examples+ ci_ref <- strat_wilson_by_grp[[1]] |
||
| 120 | -+ | |||
| 630 | +4x |
- #' # level_order --------+ ci_trt <- strat_wilson_by_grp[[2]] |
||
| 121 | -+ | |||
| 631 | +4x |
- #' # Even if default would bring ref_group first, the original order puts it last+ l_ref <- as.numeric(ci_ref$conf_int[1]) |
||
| 122 | -+ | |||
| 632 | +4x |
- #' basic_table() %>%+ u_ref <- as.numeric(ci_ref$conf_int[2]) |
||
| 123 | -+ | |||
| 633 | +4x |
- #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
+ l_trt <- as.numeric(ci_trt$conf_int[1]) |
||
| 124 | -+ | |||
| 634 | +4x |
- #' analyze("Sepal.Length") %>%
+ u_trt <- as.numeric(ci_trt$conf_int[2]) |
||
| 125 | +635 |
- #' build_table(iris)+ |
||
| 126 | +636 |
- #'+ # Estimating the diff and n_ref, n_trt (it allows different weights to be used) |
||
| 127 | -+ | |||
| 637 | +4x |
- #' # character vector+ t_tbl <- table( |
||
| 128 | -+ | |||
| 638 | +4x |
- #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)])+ factor(rsp, levels = c("FALSE", "TRUE")),
|
||
| 129 | -+ | |||
| 639 | +4x |
- #' basic_table() %>%+ grp, |
||
| 130 | -+ | |||
| 640 | +4x |
- #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
+ strata |
||
| 131 | +641 |
- #' analyze("Sepal.Length") %>%
+ ) |
||
| 132 | -+ | |||
| 642 | +4x |
- #' build_table(iris)+ n_ref <- colSums(t_tbl[1:2, 1, ]) |
||
| 133 | -+ | |||
| 643 | +4x |
- #'+ n_trt <- colSums(t_tbl[1:2, 2, ]) |
||
| 134 | -+ | |||
| 644 | +4x |
- #' @export+ use_stratum <- (n_ref > 0) & (n_trt > 0) |
||
| 135 | -+ | |||
| 645 | +4x |
- level_order <- function(order) {
+ n_ref <- n_ref[use_stratum] |
||
| 136 | -2x | +646 | +4x |
- make_split_fun(+ n_trt <- n_trt[use_stratum] |
| 137 | -2x | +647 | +4x |
- post = list(+ p_ref <- t_tbl[2, 1, use_stratum] / n_ref |
| 138 | -2x | +648 | +4x |
- function(splret, spl, fulldf) {
+ p_trt <- t_tbl[2, 2, use_stratum] / n_trt |
| 139 | +649 | 4x |
- if (checkmate::test_integerish(order)) {
+ est1 <- sum(weights * p_ref) |
|
| 140 | -1x | +650 | +4x |
- checkmate::assert_integerish(order, lower = 1, upper = length(splret$values))+ est2 <- sum(weights * p_trt) |
| 141 | -1x | +651 | +4x |
- ord <- order+ diff_est <- est2 - est1 |
| 142 | +652 |
- } else {
+
|
||
| 143 | -3x | +653 | +4x |
- checkmate::assert_character(order, len = length(splret$values))+ lambda1 <- sum(weights^2 / n_ref) |
| 144 | -3x | +654 | +4x |
- checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE)+ lambda2 <- sum(weights^2 / n_trt) |
| 145 | -3x | +655 | +4x |
- ord <- match(order, names(splret$values))+ z <- stats::qnorm((1 + conf_level) / 2) |
| 146 | +656 |
- }+ |
||
| 147 | +657 | 4x |
- make_split_result(+ lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref)) |
|
| 148 | +658 | 4x |
- splret$values[ord],+ upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt)) |
|
| 149 | -4x | +|||
| 659 | +
- splret$datasplit[ord],+ |
|||
| 150 | +660 | 4x |
- splret$labels[ord]- |
- |
| 151 | -- |
- )+ list( |
||
| 152 | -+ | |||
| 661 | +4x |
- }+ "diff" = diff_est, |
||
| 153 | -+ | |||
| 662 | +4x |
- )+ "diff_ci" = c("lower" = lower, "upper" = upper)
|
||
| 154 | +663 |
) |
||
| 155 | +664 |
}@@ -136264,14 +134272,14 @@ tern coverage - 95.65% |
| 1 |
- #' Cox regression helper function for interactions+ #' Bland-Altman analysis |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' Test and estimate the effect of a treatment in interaction with a covariate.+ #' Statistics function that uses the Bland-Altman method to assess the agreement between two numerical vectors |
||
| 6 |
- #' The effect is estimated as the HR of the tested treatment for a given level+ #' and calculates a variety of statistics. |
||
| 7 |
- #' of the covariate, in comparison to the treatment control.+ #' |
||
| 8 |
- #'+ #' @inheritParams argument_convention |
||
| 9 |
- #' @inheritParams argument_convention+ #' @param y (`numeric`)\cr vector of numbers we want to analyze, to be compared with `x`. |
||
| 10 |
- #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested.+ #' |
||
| 11 |
- #' @param effect (`string`)\cr the name of the effect to be tested and estimated.+ #' @return |
||
| 12 |
- #' @param covar (`string`)\cr the name of the covariate in the model.+ #' A named list of the following elements: |
||
| 13 |
- #' @param mod (`coxph`)\cr the Cox regression model.+ #' * `df` |
||
| 14 |
- #' @param label (`string`)\cr the label to be returned as `term_label`.+ #' * `difference_mean` |
||
| 15 |
- #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()].+ #' * `ci_mean` |
||
| 16 |
- #' @param ... see methods.+ #' * `difference_sd` |
||
| 17 |
- #'+ #' * `difference_se` |
||
| 18 |
- #' @examples+ #' * `upper_agreement_limit` |
||
| 19 |
- #' library(survival)+ #' * `lower_agreement_limit` |
||
| 20 |
- #'+ #' * `agreement_limit_se` |
||
| 21 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' * `upper_agreement_limit_ci` |
||
| 22 |
- #'+ #' * `lower_agreement_limit_ci` |
||
| 23 |
- #' # Testing dataset [survival::bladder].+ #' * `t_value` |
||
| 24 |
- #' dta_bladder <- with(+ #' * `n` |
||
| 25 |
- #' data = bladder[bladder$enum < 5, ],+ #' |
||
| 26 |
- #' data.frame(+ #' @examples |
||
| 27 |
- #' time = stop,+ #' x <- seq(1, 60, 5) |
||
| 28 |
- #' status = event,+ #' y <- seq(5, 50, 4) |
||
| 29 |
- #' armcd = as.factor(rx),+ #' |
||
| 30 |
- #' covar1 = as.factor(enum),+ #' s_bland_altman(x, y, conf_level = 0.9) |
||
| 31 |
- #' covar2 = factor(+ #' |
||
| 32 |
- #' sample(as.factor(enum)),+ #' @export |
||
| 33 |
- #' levels = 1:4,+ s_bland_altman <- function(x, y, conf_level = 0.95) {
|
||
| 34 | -+ | 7x |
- #' labels = c("F", "F", "M", "M")
+ checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE) |
| 35 | -+ | 6x |
- #' )+ checkmate::assert_numeric(y, len = length(x), any.missing = TRUE) |
| 36 | -+ | 5x |
- #' )+ checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE) |
| 37 |
- #' )+ |
||
| 38 | -+ | 4x |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ alpha <- 1 - conf_level |
| 39 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ |
||
| 40 | -+ | 4x |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length |
| 41 | -+ | 4x |
- #'+ x <- x[ind] |
| 42 | -+ | 4x |
- #' plot(+ y <- y[ind] |
| 43 | -+ | 4x |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ n <- sum(ind) # number of 'observations' |
| 44 |
- #' lty = 2:4,+ |
||
| 45 | -+ | 4x |
- #' xlab = "Months",+ if (n == 0) {
|
| 46 | -+ | ! |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ stop("there is no valid paired data")
|
| 47 |
- #' )+ } |
||
| 48 |
- #'+ |
||
| 49 | -+ | 4x |
- #' @name cox_regression_inter+ difference <- x - y # vector of differences |
| 50 | -+ | 4x |
- NULL+ average <- (x + y) / 2 # vector of means |
| 51 | -+ | 4x |
-
+ difference_mean <- mean(difference) # mean difference |
| 52 | -+ | 4x |
- #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect.+ difference_sd <- sd(difference) # SD of differences |
| 53 | -+ | 4x |
- #'+ al <- qnorm(1 - alpha / 2) * difference_sd |
| 54 | -+ | 4x |
- #' @return+ upper_agreement_limit <- difference_mean + al # agreement limits |
| 55 | -+ | 4x |
- #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following+ lower_agreement_limit <- difference_mean - al |
| 56 |
- #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`.+ |
||
| 57 | -+ | 4x |
- #'+ difference_se <- difference_sd / sqrt(n) # standard error of the mean |
| 58 | -+ | 4x |
- #' @export+ al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit |
| 59 | -+ | 4x |
- h_coxreg_inter_effect <- function(x,+ tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation |
| 60 | -+ | 4x |
- effect,+ difference_mean_ci <- difference_se * tvalue |
| 61 | -+ | 4x |
- covar,+ al_ci <- al_se * tvalue |
| 62 | -+ | 4x |
- mod,+ upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci) |
| 63 | -+ | 4x |
- label,+ lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci) |
| 64 |
- control,+ |
||
| 65 | -+ | 4x |
- ...) {
+ list( |
| 66 | -29x | +4x |
- UseMethod("h_coxreg_inter_effect", x)
+ df = data.frame(average, difference), |
| 67 | -+ | 4x |
- }+ difference_mean = difference_mean, |
| 68 | -+ | 4x |
-
+ ci_mean = difference_mean + c(-1, 1) * difference_mean_ci, |
| 69 | -+ | 4x |
- #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate.+ difference_sd = difference_sd, |
| 70 | -+ | 4x |
- #'+ difference_se = difference_se, |
| 71 | -+ | 4x |
- #' @method h_coxreg_inter_effect numeric+ upper_agreement_limit = upper_agreement_limit, |
| 72 | -+ | 4x |
- #'+ lower_agreement_limit = lower_agreement_limit, |
| 73 | -+ | 4x |
- #' @param at (`list`)\cr a list with items named after the covariate, every+ agreement_limit_se = al_se, |
| 74 | -+ | 4x |
- #' item is a vector of levels at which the interaction should be estimated.+ upper_agreement_limit_ci = upper_agreement_limit_ci, |
| 75 | -+ | 4x |
- #'+ lower_agreement_limit_ci = lower_agreement_limit_ci, |
| 76 | -+ | 4x |
- #' @export+ t_value = tvalue, |
| 77 | -+ | 4x |
- h_coxreg_inter_effect.numeric <- function(x,+ n = n |
| 78 |
- effect,+ ) |
||
| 79 |
- covar,+ } |
||
| 80 |
- mod,+ |
||
| 81 |
- label,+ #' Bland-Altman plot |
||
| 82 |
- control,+ #' |
||
| 83 |
- at,+ #' @description `r lifecycle::badge("experimental")`
|
||
| 84 |
- ...) {
+ #' |
||
| 85 | -7x | +
- betas <- stats::coef(mod)+ #' Graphing function that produces a Bland-Altman plot. |
|
| 86 | -7x | +
- attrs <- attr(stats::terms(mod), "term.labels")+ #' |
|
| 87 | -7x | +
- term_indices <- grep(+ #' @inheritParams s_bland_altman |
|
| 88 | -7x | +
- pattern = effect,+ #' |
|
| 89 | -7x | +
- x = attrs[!grepl("strata\\(", attrs)]
+ #' @return A `ggplot` Bland-Altman plot. |
|
| 90 |
- )+ #' |
||
| 91 | -7x | +
- checkmate::assert_vector(term_indices, len = 2)+ #' @examples |
|
| 92 | -7x | +
- betas <- betas[term_indices]+ #' x <- seq(1, 60, 5) |
|
| 93 | -7x | +
- betas_var <- diag(stats::vcov(mod))[term_indices]+ #' y <- seq(5, 50, 4) |
|
| 94 | -7x | +
- betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]+ #' |
|
| 95 | -7x | +
- xval <- if (is.null(at[[covar]])) {
+ #' g_bland_altman(x = x, y = y, conf_level = 0.9) |
|
| 96 | -6x | +
- stats::median(x)+ #' |
|
| 97 |
- } else {
+ #' @export |
||
| 98 | -1x | +
- at[[covar]]+ #' @aliases bland_altman |
|
| 99 |
- }+ g_bland_altman <- function(x, y, conf_level = 0.95) {
|
||
| 100 | -7x | +1x |
- effect_index <- !grepl(covar, names(betas))+ result_tem <- s_bland_altman(x, y, conf_level = conf_level) |
| 101 | -7x | +1x |
- coef_hat <- betas[effect_index] + xval * betas[!effect_index]+ xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1 |
| 102 | -7x | +1x |
- coef_se <- sqrt(+ yrange <- diff(range(result_tem$df$difference)) |
| 103 | -7x | +
- betas_var[effect_index] ++ |
|
| 104 | -7x | +1x |
- xval ^ 2 * betas_var[!effect_index] + # styler: off+ p <- ggplot(result_tem$df) + |
| 105 | -7x | +1x |
- 2 * xval * betas_cov+ geom_point(aes(x = average, y = difference), color = "blue") + |
| 106 | -+ | 1x |
- )+ geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) + |
| 107 | -7x | +1x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ geom_hline(yintercept = 0, color = "blue", linetype = 2) + |
| 108 | -7x | +1x |
- data.frame(+ geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) + |
| 109 | -7x | +1x |
- effect = "Covariate:",+ geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) + |
| 110 | -7x | +1x |
- term = rep(covar, length(xval)),+ annotate( |
| 111 | -7x | +1x |
- term_label = paste0(" ", xval),
+ "text", |
| 112 | -7x | +1x |
- level = as.character(xval),+ x = xpos, |
| 113 | -7x | +1x |
- n = NA,+ y = result_tem$lower_agreement_limit + 0.03 * yrange, |
| 114 | -7x | +1x |
- hr = exp(coef_hat),+ label = "lower limits of agreement", |
| 115 | -7x | +1x |
- lcl = exp(coef_hat - q_norm * coef_se),+ color = "red" |
| 116 | -7x | +
- ucl = exp(coef_hat + q_norm * coef_se),+ ) + |
|
| 117 | -7x | +1x |
- pval = NA,+ annotate( |
| 118 | -7x | +1x |
- pval_inter = NA,+ "text", |
| 119 | -7x | +1x |
- stringsAsFactors = FALSE+ x = xpos, |
| 120 | -+ | 1x |
- )+ y = result_tem$upper_agreement_limit + 0.03 * yrange, |
| 121 | -+ | 1x |
- }+ label = "upper limits of agreement", |
| 122 | -+ | 1x |
-
+ color = "red" |
| 123 |
- #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate.+ ) + |
||
| 124 | -+ | 1x |
- #'+ annotate( |
| 125 | -+ | 1x |
- #' @method h_coxreg_inter_effect factor+ "text", |
| 126 | -+ | 1x |
- #'+ x = xpos, |
| 127 | -+ | 1x |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ y = result_tem$difference_mean + 0.03 * yrange, |
| 128 | -+ | 1x |
- #'+ label = "mean of difference between two measures", |
| 129 | -+ | 1x |
- #' @export+ color = "blue" |
| 130 |
- h_coxreg_inter_effect.factor <- function(x,+ ) + |
||
| 131 | -+ | 1x |
- effect,+ annotate( |
| 132 | -+ | 1x |
- covar,+ "text", |
| 133 | -+ | 1x |
- mod,+ x = xpos, |
| 134 | -+ | 1x |
- label,+ y = result_tem$lower_agreement_limit - 0.03 * yrange, |
| 135 | -+ | 1x |
- control,+ label = sprintf("%.2f", result_tem$lower_agreement_limit),
|
| 136 | -+ | 1x |
- data,+ color = "red" |
| 137 |
- ...) {
+ ) + |
||
| 138 | -17x | +1x |
- lvl_given <- levels(x)+ annotate( |
| 139 | -17x | +1x |
- y <- h_coxreg_inter_estimations(+ "text", |
| 140 | -17x | +1x |
- variable = effect, given = covar,+ x = xpos, |
| 141 | -17x | +1x |
- lvl_var = levels(data[[effect]]),+ y = result_tem$upper_agreement_limit - 0.03 * yrange, |
| 142 | -17x | +1x |
- lvl_given = lvl_given,+ label = sprintf("%.2f", result_tem$upper_agreement_limit),
|
| 143 | -17x | +1x |
- mod = mod,+ color = "red" |
| 144 | -17x | +
- conf_level = 0.95+ ) + |
|
| 145 | -17x | +1x |
- )[[1]]+ annotate( |
| 146 | -+ | 1x |
-
+ "text", |
| 147 | -17x | +1x |
- data.frame(+ x = xpos, |
| 148 | -17x | +1x |
- effect = "Covariate:",+ y = result_tem$difference_mean - 0.03 * yrange, |
| 149 | -17x | +1x |
- term = rep(covar, nrow(y)),+ label = sprintf("%.2f", result_tem$difference_meanm),
|
| 150 | -17x | +1x |
- term_label = paste0(" ", lvl_given),
+ color = "blue" |
| 151 | -17x | +
- level = lvl_given,+ ) + |
|
| 152 | -17x | +1x |
- n = NA,+ xlab("Average of two measures") +
|
| 153 | -17x | +1x |
- hr = y[, "hr"],+ ylab("Difference between two measures")
|
| 154 | -17x | +
- lcl = y[, "lcl"],+ |
|
| 155 | -17x | +1x |
- ucl = y[, "ucl"],+ return(p) |
| 156 | -17x | +
- pval = NA,+ } |
|
| 157 | -17x | +
| 1 | +
- pval_inter = NA,+ #' Encode categorical missing values in a data frame |
|||
| 158 | -17x | +|||
| 2 | +
- stringsAsFactors = FALSE+ #' |
|||
| 159 | +3 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 160 | +4 |
- }+ #' |
||
| 161 | +5 |
-
+ #' This is a helper function to encode missing entries across groups of categorical |
||
| 162 | +6 |
- #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate.+ #' variables in a data frame. |
||
| 163 | +7 |
- #' This makes an automatic conversion to `factor` and then forwards to the method for factors.+ #' |
||
| 164 | +8 |
- #'+ #' @details Missing entries are those with `NA` or empty strings and will |
||
| 165 | +9 |
- #' @method h_coxreg_inter_effect character+ #' be replaced with a specified value. If factor variables include missing |
||
| 166 | +10 |
- #'+ #' values, the missing value will be inserted as the last level. |
||
| 167 | +11 |
- #' @note+ #' Similarly, in case character or logical variables should be converted to factors |
||
| 168 | +12 |
- #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is+ #' with the `char_as_factor` or `logical_as_factor` options, the missing values will |
||
| 169 | +13 |
- #' therefore better to always pre-process the dataset such that factors are manually created from character+ #' be set as the last level. |
||
| 170 | +14 |
- #' variables before passing the dataset to [rtables::build_table()].+ #' |
||
| 171 | +15 |
- #'+ #' @param data (`data.frame`)\cr data set. |
||
| 172 | +16 |
- #' @export+ #' @param omit_columns (`character`)\cr names of variables from `data` that should |
||
| 173 | +17 |
- h_coxreg_inter_effect.character <- function(x,+ #' not be modified by this function. |
||
| 174 | +18 |
- effect,+ #' @param char_as_factor (`flag`)\cr whether to convert character variables |
||
| 175 | +19 |
- covar,+ #' in `data` to factors. |
||
| 176 | +20 |
- mod,+ #' @param logical_as_factor (`flag`)\cr whether to convert logical variables |
||
| 177 | +21 |
- label,+ #' in `data` to factors. |
||
| 178 | +22 |
- control,+ #' @param na_level (`string`)\cr string used to replace all `NA` or empty |
||
| 179 | +23 |
- data,+ #' values inside non-`omit_columns` columns. |
||
| 180 | +24 |
- ...) {
+ #' |
||
| 181 | -5x | +|||
| 25 | +
- y <- as.factor(x)+ #' @return A `data.frame` with the chosen modifications applied. |
|||
| 182 | +26 |
-
+ #' |
||
| 183 | -5x | +|||
| 27 | +
- h_coxreg_inter_effect(+ #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions. |
|||
| 184 | -5x | +|||
| 28 | +
- x = y,+ #' |
|||
| 185 | -5x | +|||
| 29 | +
- effect = effect,+ #' @examples |
|||
| 186 | -5x | +|||
| 30 | +
- covar = covar,+ #' my_data <- data.frame( |
|||
| 187 | -5x | +|||
| 31 | +
- mod = mod,+ #' u = c(TRUE, FALSE, NA, TRUE), |
|||
| 188 | -5x | +|||
| 32 | +
- label = label,+ #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
|
|||
| 189 | -5x | +|||
| 33 | +
- control = control,+ #' w = c("A", "B", NA, "C"),
|
|||
| 190 | -5x | +|||
| 34 | +
- data = data,+ #' x = c("D", "E", "F", NA),
|
|||
| 191 | +35 |
- ...+ #' y = c("G", "H", "I", ""),
|
||
| 192 | +36 |
- )+ #' z = c(1, 2, 3, 4), |
||
| 193 | +37 |
- }+ #' stringsAsFactors = FALSE |
||
| 194 | +38 |
-
+ #' ) |
||
| 195 | +39 |
- #' @describeIn cox_regression_inter A higher level function to get+ #' |
||
| 196 | +40 |
- #' the results of the interaction test and the estimated values.+ #' # Example 1 |
||
| 197 | +41 |
- #'+ #' # Encode missing values in all character or factor columns. |
||
| 198 | +42 |
- #' @return+ #' df_explicit_na(my_data) |
||
| 199 | +43 |
- #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If+ #' # Also convert logical columns to factor columns. |
||
| 200 | +44 |
- #' no interaction, [h_coxreg_univar_extract()] is applied instead.+ #' df_explicit_na(my_data, logical_as_factor = TRUE) |
||
| 201 | +45 |
- #'+ #' # Encode missing values in a subset of columns. |
||
| 202 | +46 |
- #' @examples+ #' df_explicit_na(my_data, omit_columns = c("x", "y"))
|
||
| 203 | +47 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' |
||
| 204 | +48 |
- #' h_coxreg_extract_interaction(+ #' # Example 2 |
||
| 205 | +49 |
- #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder,+ #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable. |
||
| 206 | +50 |
- #' control = control_coxreg()+ #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not |
||
| 207 | +51 |
- #' )+ #' # included when generating `rtables`. |
||
| 208 | +52 |
- #'+ #' adsl <- tern_ex_adsl |
||
| 209 | +53 |
- #' @export+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 210 | +54 |
- h_coxreg_extract_interaction <- function(effect,+ #' adsl <- df_explicit_na(adsl) |
||
| 211 | +55 |
- covar,+ #' |
||
| 212 | +56 |
- mod,+ #' # If you want the `Na` values to be displayed in the table use the `na_level` argument. |
||
| 213 | +57 |
- data,+ #' adsl <- tern_ex_adsl |
||
| 214 | +58 |
- at,+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 215 | +59 |
- control) {
+ #' adsl <- df_explicit_na(adsl, na_level = "Missing Values") |
||
| 216 | -31x | +|||
| 60 | +
- if (!any(attr(stats::terms(mod), "order") == 2)) {
+ #' |
|||
| 217 | -12x | +|||
| 61 | +
- y <- h_coxreg_univar_extract(+ #' # Example 3 |
|||
| 218 | -12x | +|||
| 62 | +
- effect = effect, covar = covar, mod = mod, data = data, control = control+ #' # Numeric variables that have missing values are not altered. This means that any `NA` value in |
|||
| 219 | +63 |
- )+ #' # a numeric variable will not be included in the summary statistics, nor will they be included |
||
| 220 | -12x | +|||
| 64 | +
- y$pval_inter <- NA+ #' # in the denominator value for calculating the percent values. |
|||
| 221 | -12x | +|||
| 65 | +
- y+ #' adsl <- tern_ex_adsl |
|||
| 222 | +66 |
- } else {
+ #' adsl$AGE[adsl$AGE < 30] <- NA |
||
| 223 | -19x | +|||
| 67 | +
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ #' adsl <- df_explicit_na(adsl) |
|||
| 224 | +68 |
-
+ #' |
||
| 225 | +69 |
- # Test the main treatment effect.+ #' @export |
||
| 226 | -19x | +|||
| 70 | +
- mod_aov <- muffled_car_anova(mod, test_statistic)+ df_explicit_na <- function(data, |
|||
| 227 | -19x | +|||
| 71 | +
- sum_anova <- broom::tidy(mod_aov)+ omit_columns = NULL, |
|||
| 228 | -19x | +|||
| 72 | +
- pval <- sum_anova[sum_anova$term == effect, ][["p.value"]]+ char_as_factor = TRUE, |
|||
| 229 | +73 |
-
+ logical_as_factor = FALSE, |
||
| 230 | +74 |
- # Test the interaction effect.+ na_level = "<Missing>") {
|
||
| 231 | -19x | +75 | +24x |
- pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
+ checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) |
| 232 | -19x | +76 | +23x |
- covar_test <- data.frame(+ checkmate::assert_data_frame(data) |
| 233 | -19x | +77 | +22x |
- effect = "Covariate:",+ checkmate::assert_flag(char_as_factor) |
| 234 | -19x | +78 | +21x |
- term = covar,+ checkmate::assert_flag(logical_as_factor) |
| 235 | -19x | +79 | +21x |
- term_label = unname(labels_or_names(data[covar])),+ checkmate::assert_string(na_level)+ |
+
| 80 | ++ | + | ||
| 236 | +81 | 19x |
- level = "",+ target_vars <- if (is.null(omit_columns)) {
|
|
| 237 | -19x | +82 | +17x |
- n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval,+ names(data)+ |
+
| 83 | ++ |
+ } else {
|
||
| 238 | -19x | +84 | +2x |
- pval_inter = pval_inter,+ setdiff(names(data), omit_columns) # May have duplicates.+ |
+
| 85 | ++ |
+ } |
||
| 239 | +86 | 19x |
- stringsAsFactors = FALSE+ if (length(target_vars) == 0) {
+ |
+ |
| 87 | +1x | +
+ return(data) |
||
| 240 | +88 |
- )+ } |
||
| 241 | +89 |
- # Estimate the interaction.+ |
||
| 242 | -19x | +90 | +18x |
- y <- h_coxreg_inter_effect(+ l_target_vars <- split(target_vars, target_vars) |
| 243 | -19x | +|||
| 91 | +
- data[[covar]],+ |
|||
| 244 | -19x | +|||
| 92 | +
- covar = covar,+ # Makes sure target_vars exist in data and names are not duplicated. |
|||
| 245 | -19x | +93 | +18x |
- effect = effect,+ assert_df_with_variables(data, l_target_vars) |
| 246 | -19x | +|||
| 94 | +
- mod = mod,+ |
|||
| 247 | -19x | +95 | +18x |
- label = unname(labels_or_names(data[covar])),+ for (x in target_vars) {
|
| 248 | -19x | +96 | +306x |
- at = at,+ xi <- data[[x]] |
| 249 | -19x | +97 | +306x |
- control = control,+ xi_label <- obj_label(xi) |
| 250 | -19x | +|||
| 98 | +
- data = data+ |
|||
| 251 | +99 |
- )+ # Determine whether to convert character or logical input. |
||
| 252 | -19x | +100 | +306x |
- rbind(covar_test, y)+ do_char_conversion <- is.character(xi) && char_as_factor |
| 253 | -+ | |||
| 101 | +306x |
- }+ do_logical_conversion <- is.logical(xi) && logical_as_factor |
||
| 254 | +102 |
- }+ |
||
| 255 | +103 |
-
+ # Pre-convert logical to character to deal correctly with replacing NA |
||
| 256 | +104 |
- #' @describeIn cox_regression_inter Hazard ratio estimation in interactions.+ # values below. |
||
| 257 | -+ | |||
| 105 | +306x |
- #'+ if (do_logical_conversion) {
|
||
| 258 | -+ | |||
| 106 | +2x |
- #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation+ xi <- as.character(xi) |
||
| 259 | +107 |
- #' of the levels of `variable` given the levels of `given`.+ } |
||
| 260 | +108 |
- #' @param lvl_var,lvl_given (`character`)\cr corresponding levels as given by [levels()].+ + |
+ ||
| 109 | +306x | +
+ if (is.factor(xi) || is.character(xi)) {
|
||
| 261 | +110 |
- #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]).+ # Handle empty strings and NA values.+ |
+ ||
| 111 | +219x | +
+ xi <- explicit_na(sas_na(xi), label = na_level) |
||
| 262 | +112 |
- #'+ |
||
| 263 | +113 |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ # Convert to factors if requested for the original type, |
||
| 264 | +114 |
- #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex.+ # set na_level as the last value.+ |
+ ||
| 115 | +219x | +
+ if (do_char_conversion || do_logical_conversion) {
+ |
+ ||
| 116 | +78x | +
+ levels_xi <- setdiff(sort(unique(xi)), na_level)+ |
+ ||
| 117 | +78x | +
+ if (na_level %in% unique(xi)) {
+ |
+ ||
| 118 | +18x | +
+ levels_xi <- c(levels_xi, na_level) |
||
| 265 | +119 |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ } |
||
| 266 | +120 |
- #'+ + |
+ ||
| 121 | +78x | +
+ xi <- factor(xi, levels = levels_xi) |
||
| 267 | +122 |
- #' - b1 (arm b), b2 (arm c)+ } |
||
| 268 | +123 |
- #' - b3 (sex m)+ + |
+ ||
| 124 | +219x | +
+ data[, x] <- formatters::with_label(xi, label = xi_label) |
||
| 269 | +125 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ } |
||
| 270 | +126 |
- #'+ }+ |
+ ||
| 127 | +18x | +
+ return(data) |
||
| 271 | +128 |
- #' The estimation of the Hazard Ratio for arm C/sex M is given in reference+ } |
| 272 | +1 |
- #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5).+ #' Kaplan-Meier plot |
|
| 273 | +2 |
- #' The interaction coefficient is deduced by b2 + b5 while the standard error+ #' |
|
| 274 | +3 |
- #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$.+ #' @description `r lifecycle::badge("stable")`
|
|
| 275 | +4 |
#' |
|
| 276 | +5 |
- #' @return+ #' From a survival model, a graphic is rendered along with tabulated annotation |
|
| 277 | +6 |
- #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding+ #' including the number of patient at risk at given time and the median survival |
|
| 278 | +7 |
- #' to the combinations of `variable` and `given`, with columns:+ #' per group. |
|
| 279 | +8 |
- #' * `coef_hat`: Estimation of the coefficient.+ #' |
|
| 280 | +9 |
- #' * `coef_se`: Standard error of the estimation.+ #' @inheritParams argument_convention |
|
| 281 | +10 |
- #' * `hr`: Hazard ratio.+ #' @param variables (named `list`)\cr variable names. Details are: |
|
| 282 | +11 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values. |
|
| 283 | +12 |
- #'+ #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored. |
|
| 284 | +13 |
- #' @examples+ #' * `arm` (`factor`)\cr the treatment group variable. |
|
| 285 | +14 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors. |
|
| 286 | +15 |
- #' result <- h_coxreg_inter_estimations(+ #' @param control_surv (`list`)\cr parameters for comparison details, specified by using |
|
| 287 | +16 |
- #' variable = "armcd", given = "covar1",+ #' the helper function [control_surv_timepoint()]. Some possible parameter options are: |
|
| 288 | +17 |
- #' lvl_var = levels(dta_bladder$armcd),+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
|
| 289 | +18 |
- #' lvl_given = levels(dta_bladder$covar1),+ #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type, |
|
| 290 | +19 |
- #' mod = mod, conf_level = .95+ #' see more in [survival::survfit()]. Note that the option "none" is no longer supported. |
|
| 291 | +20 |
- #' )+ #' @param col (`character`)\cr lines colors. Length of a vector should be equal |
|
| 292 | +21 |
- #' result+ #' to number of strata from [survival::survfit()]. |
|
| 293 | +22 |
- #'+ #' @param lty (`numeric`)\cr line type. If a vector is given, its length should be equal to the number of strata from |
|
| 294 | +23 |
- #' @export+ #' [survival::survfit()]. |
|
| 295 | +24 |
- h_coxreg_inter_estimations <- function(variable,+ #' @param lwd (`numeric`)\cr line width. If a vector is given, its length should be equal to the number of strata from |
|
| 296 | +25 |
- given,+ #' [survival::survfit()]. |
|
| 297 | +26 |
- lvl_var,+ #' @param censor_show (`flag`)\cr whether to show censored observations. |
|
| 298 | +27 |
- lvl_given,+ #' @param pch (`string`)\cr name of symbol or character to use as point symbol to indicate censored cases. |
|
| 299 | +28 |
- mod,+ #' @param size (`numeric(1)`)\cr size of censored point symbols. |
|
| 300 | +29 |
- conf_level = 0.95) {
+ #' @param max_time (`numeric(1)`)\cr maximum value to show on x-axis. Only data values less than or up to |
|
| 301 | -18x | +||
| 30 | +
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ #' this threshold value will be plotted (defaults to `NULL`). |
||
| 302 | -18x | +||
| 31 | +
- giv_lvl <- paste0(given, lvl_given)+ #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing |
||
| 303 | -18x | +||
| 32 | +
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ #' between ticks on the x-axis. If `NULL` (default), [labeling::extended()] is used to determine |
||
| 304 | -18x | +||
| 33 | +
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ #' optimal tick positions on the x-axis. |
||
| 305 | -18x | +||
| 34 | +
- design_mat <- within(+ #' @param xlab (`string`)\cr x-axis label. |
||
| 306 | -18x | +||
| 35 | +
- data = design_mat,+ #' @param yval (`string`)\cr type of plot, to be plotted on the y-axis. Options are `Survival` (default) and `Failure` |
||
| 307 | -18x | +||
| 36 | +
- expr = {
+ #' probability. |
||
| 308 | -18x | +||
| 37 | +
- inter <- paste0(variable, ":", given)+ #' @param ylab (`string`)\cr y-axis label. |
||
| 309 | -18x | +||
| 38 | +
- rev_inter <- paste0(given, ":", variable)+ #' @param title (`string`)\cr plot title. |
||
| 310 | +39 |
- }+ #' @param footnotes (`string`)\cr plot footnotes. |
|
| 311 | +40 |
- )+ #' @param font_size (`numeric(1)`)\cr font size to use for all text. |
|
| 312 | -18x | +||
| 41 | +
- split_by_variable <- design_mat$variable+ #' @param ci_ribbon (`flag`)\cr whether the confidence interval should be drawn around the Kaplan-Meier curve. |
||
| 313 | -18x | +||
| 42 | +
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk |
||
| 314 | +43 |
-
+ #' matching the main grid of the Kaplan-Meier curve. |
|
| 315 | -18x | +||
| 44 | +
- mmat <- stats::model.matrix(mod)[1, ]+ #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
||
| 316 | -18x | +||
| 45 | +
- mmat[!mmat == 0] <- 0+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
||
| 317 | +46 |
-
+ #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the |
|
| 318 | -18x | +||
| 47 | +
- design_mat <- apply(+ #' median survival time per group. |
||
| 319 | -18x | +||
| 48 | +
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ #' @param annot_coxph (`flag`)\cr whether to add the annotation table from a [survival::coxph()] model. |
||
| 320 | -52x | +||
| 49 | +
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ #' @param annot_stats (`string` or `NULL`)\cr statistics annotations to add to the plot. Options are |
||
| 321 | -52x | +||
| 50 | +
- mmat+ #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time). |
||
| 322 | +51 |
- }+ #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics |
|
| 323 | +52 |
- )+ #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added. |
|
| 324 | -18x | +||
| 53 | +
- colnames(design_mat) <- interaction_names+ #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified using the helper function |
||
| 325 | +54 |
-
+ #' [control_coxph()]. Some possible parameter options are: |
|
| 326 | -18x | +||
| 55 | +
- coef <- stats::coef(mod)+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. |
||
| 327 | -18x | +||
| 56 | +
- vcov <- stats::vcov(mod)+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
||
| 328 | -18x | +||
| 57 | +
- betas <- as.matrix(coef)+ #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`, |
||
| 329 | -18x | +||
| 58 | +
- coef_hat <- t(design_mat) %*% betas+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()] |
||
| 330 | -18x | +||
| 59 | +
- dimnames(coef_hat)[2] <- "coef"+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
||
| 331 | -18x | +||
| 60 | +
- coef_se <- apply(+ #' @param ref_group_coxph (`string` or `NULL`)\cr level of arm variable to use as reference group in calculations for |
||
| 332 | -18x | +||
| 61 | +
- design_mat, 2,+ #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable. |
||
| 333 | -18x | +||
| 62 | +
- function(x) {
+ #' @param control_annot_surv_med (`list`)\cr parameters to control the position and size of the annotation table added |
||
| 334 | -52x | +||
| 63 | +
- vcov_el <- as.logical(x)+ #' to the plot when `annot_surv_med = TRUE`, specified using the [control_surv_med_annot()] function. Parameter |
||
| 335 | -52x | +||
| 64 | +
- y <- vcov[vcov_el, vcov_el]+ #' options are: `x`, `y`, `w`, `h`, and `fill`. See [control_surv_med_annot()] for details. |
||
| 336 | -52x | +||
| 65 | +
- y <- sum(y)+ #' @param control_annot_coxph (`list`)\cr parameters to control the position and size of the annotation table added |
||
| 337 | -52x | +||
| 66 | +
- y <- sqrt(y)+ #' to the plot when `annot_coxph = TRUE`, specified using the [control_coxph_annot()] function. Parameter |
||
| 338 | -52x | +||
| 67 | +
- return(y)+ #' options are: `x`, `y`, `w`, `h`, `fill`, and `ref_lbls`. See [control_coxph_annot()] for details. |
||
| 339 | +68 |
- }+ #' @param legend_pos (`numeric(2)` or `NULL`)\cr vector containing x- and y-coordinates, respectively, for the legend |
|
| 340 | +69 |
- )+ #' position relative to the KM plot area. If `NULL` (default), the legend is positioned in the bottom right corner of |
|
| 341 | -18x | +||
| 70 | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ #' the plot, or the middle right of the plot if needed to prevent overlapping. |
||
| 342 | -18x | +||
| 71 | +
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the Kaplan-Meier plot. |
||
| 343 | -18x | +||
| 72 | +
- y <- apply(y, 1, function(x) {
+ #' Relative height of patients at risk table is then `1 - rel_height_plot`. If `annot_at_risk = FALSE` or |
||
| 344 | -52x | +||
| 73 | +
- x["hr"] <- exp(x["coef"])+ #' `as_list = TRUE`, this parameter is ignored. |
||
| 345 | -52x | +||
| 74 | +
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to format the Kaplan-Meier plot. |
||
| 346 | -52x | +||
| 75 | +
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `annot_at_risk = TRUE`. |
||
| 347 | -52x | +||
| 76 | +
- x+ #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the patients |
||
| 348 | +77 |
- })+ #' at risk table is printed below the plot via [cowplot::plot_grid()]. |
|
| 349 | -18x | +||
| 78 | +
- y <- t(y)+ #' @param draw `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 350 | -18x | +||
| 79 | +
- y <- by(y, split_by_variable, identity)+ #' @param newpage `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 351 | -18x | +||
| 80 | +
- y <- lapply(y, as.matrix)+ #' @param gp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 352 | -18x | +||
| 81 | +
- attr(y, "details") <- paste0(+ #' @param vp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 353 | -18x | +||
| 82 | +
- "Estimations of ", variable,+ #' @param name `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 354 | -18x | +||
| 83 | +
- " hazard ratio given the level of ", given, " compared to ",+ #' @param annot_coxph_ref_lbls `r lifecycle::badge("deprecated")` Please use the `ref_lbls` element of
|
||
| 355 | -18x | +||
| 84 | +
- variable, " level ", lvl_var[1], "."+ #' `control_annot_coxph` instead. |
||
| 356 | +85 |
- )+ #' @param position_coxph `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
|
|
| 357 | -18x | +||
| 86 | +
- y+ #' `control_annot_coxph` instead. |
||
| 358 | +87 |
- }+ #' @param position_surv_med `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
|
| 1 | +88 |
- #' Control function for subgroup treatment effect pattern (STEP) calculations+ #' `control_annot_surv_med` instead. |
|
| 2 | +89 |
- #'+ #' @param width_annots `r lifecycle::badge("deprecated")` Please use the `w` element of `control_annot_surv_med`
|
|
| 3 | +90 |
- #' @description `r lifecycle::badge("stable")`
+ #' (for `surv_med`) and `control_annot_coxph` (for `coxph`)." |
|
| 4 | +91 |
#' |
|
| 5 | +92 |
- #' This is an auxiliary function for controlling arguments for STEP calculations.+ #' @return A `ggplot` Kaplan-Meier plot and (optionally) summary table. |
|
| 6 | +93 |
#' |
|
| 7 | +94 |
- #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which+ #' @examples |
|
| 8 | +95 |
- #' could be used to infer `bandwidth`, see below.+ #' library(dplyr) |
|
| 9 | +96 |
- #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to+ #' |
|
| 10 | +97 |
- #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data+ #' df <- tern_ex_adtte %>% |
|
| 11 | +98 |
- #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly+ #' filter(PARAMCD == "OS") %>% |
|
| 12 | +99 |
- #' distributed.+ #' mutate(is_event = CNSR == 0) |
|
| 13 | +100 |
- #' @param bandwidth (`numeric(1)` or `NULL`)\cr indicating the bandwidth of each window.+ #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD") |
|
| 14 | +101 |
- #' Depending on the argument `use_percentile`, it can be either the length of actual-value+ #' |
|
| 15 | +102 |
- #' windows on the real biomarker scale, or percentage windows.+ #' # Basic examples |
|
| 16 | +103 |
- #' If `use_percentile = TRUE`, it should be a number between 0 and 1.+ #' g_km(df = df, variables = variables) |
|
| 17 | +104 |
- #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted.+ #' g_km(df = df, variables = variables, yval = "Failure") |
|
| 18 | +105 |
- #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker`+ #' |
|
| 19 | +106 |
- #' variable for actual-value windows.+ #' # Examples with customization parameters applied |
|
| 20 | +107 |
- #' @param degree (`integer(1)`)\cr the degree of polynomial function of the biomarker as an interaction term+ #' g_km( |
|
| 21 | +108 |
- #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable+ #' df = df, |
|
| 22 | +109 |
- #' is not included in the model fitted in each biomarker window.+ #' variables = variables, |
|
| 23 | +110 |
- #' @param num_points (`integer(1)`)\cr the number of points at which the hazard ratios are estimated. The+ #' control_surv = control_surv_timepoint(conf_level = 0.9), |
|
| 24 | +111 |
- #' smallest number is 2.+ #' col = c("grey25", "grey50", "grey75"),
|
|
| 25 | +112 |
- #'+ #' annot_at_risk_title = FALSE, |
|
| 26 | +113 |
- #' @return A list of components with the same names as the arguments, except `biomarker` which is+ #' lty = 1:3, |
|
| 27 | +114 |
- #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested.+ #' font_size = 8 |
|
| 28 | +115 |
- #'+ #' ) |
|
| 29 | +116 |
- #' @examples+ #' g_km( |
|
| 30 | +117 |
- #' # Provide biomarker values and request actual values to be used,+ #' df = df, |
|
| 31 | +118 |
- #' # so that bandwidth is chosen from range.+ #' variables = variables, |
|
| 32 | +119 |
- #' control_step(biomarker = 1:10, use_percentile = FALSE)+ #' annot_stats = c("min", "median"),
|
|
| 33 | +120 |
- #'+ #' annot_stats_vlines = TRUE, |
|
| 34 | +121 |
- #' # Use a global model with quadratic biomarker interaction term.+ #' max_time = 3000, |
|
| 35 | +122 |
- #' control_step(bandwidth = NULL, degree = 2)+ #' ggtheme = ggplot2::theme_minimal() |
|
| 36 | +123 |
- #'+ #' ) |
|
| 37 | +124 |
- #' # Reduce number of points to be used.+ #' |
|
| 38 | +125 |
- #' control_step(num_points = 10)+ #' # Example with pairwise Cox-PH analysis annotation table, adjusted annotation tables |
|
| 39 | +126 |
- #'+ #' g_km( |
|
| 40 | +127 |
- #' @export+ #' df = df, variables = variables, |
|
| 41 | +128 |
- control_step <- function(biomarker = NULL,+ #' annot_coxph = TRUE, |
|
| 42 | +129 |
- use_percentile = TRUE,+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
|
| 43 | +130 |
- bandwidth,+ #' control_annot_coxph = control_coxph_annot(x = 0.26, w = 0.35), |
|
| 44 | +131 |
- degree = 0L,+ #' control_annot_surv_med = control_surv_med_annot(x = 0.8, y = 0.9, w = 0.35) |
|
| 45 | +132 |
- num_points = 39L) {
+ #' ) |
|
| 46 | -31x | +||
| 133 | +
- checkmate::assert_numeric(biomarker, null.ok = TRUE)- |
- ||
| 47 | -30x | -
- checkmate::assert_flag(use_percentile)- |
- |
| 48 | -30x | -
- checkmate::assert_int(num_points, lower = 2)- |
- |
| 49 | -29x | -
- checkmate::assert_count(degree)+ #' |
|
| 50 | +134 | - - | -|
| 51 | -29x | -
- if (missing(bandwidth)) {
+ #' @aliases kaplan_meier |
|
| 52 | +135 |
- # Infer bandwidth- |
- |
| 53 | -21x | -
- bandwidth <- if (use_percentile) {
- |
- |
| 54 | -18x | -
- 0.25- |
- |
| 55 | -21x | -
- } else if (!is.null(biomarker)) {
- |
- |
| 56 | -3x | -
- diff(range(biomarker, na.rm = TRUE)) / 4+ #' @export |
|
| 57 | +136 |
- } else {
- |
- |
| 58 | -! | -
- NULL+ g_km <- function(df, |
|
| 59 | +137 |
- }+ variables, |
|
| 60 | +138 |
- } else {
+ control_surv = control_surv_timepoint(), |
|
| 61 | +139 |
- # Check bandwidth- |
- |
| 62 | -8x | -
- if (!is.null(bandwidth)) {
- |
- |
| 63 | -5x | -
- if (use_percentile) {
- |
- |
| 64 | -4x | -
- assert_proportion_value(bandwidth)+ col = NULL, |
|
| 65 | +140 |
- } else {
- |
- |
| 66 | -1x | -
- checkmate::assert_scalar(bandwidth)- |
- |
| 67 | -1x | -
- checkmate::assert_true(bandwidth > 0)+ lty = NULL, |
|
| 68 | +141 |
- }+ lwd = 0.5, |
|
| 69 | +142 |
- }+ censor_show = TRUE, |
|
| 70 | +143 |
- }- |
- |
| 71 | -28x | -
- list(- |
- |
| 72 | -28x | -
- use_percentile = use_percentile,- |
- |
| 73 | -28x | -
- bandwidth = bandwidth,+ pch = 3, |
|
| 74 | -28x | +||
| 144 | +
- degree = as.integer(degree),+ size = 2, |
||
| 75 | -28x | +||
| 145 | +
- num_points = as.integer(num_points)+ max_time = NULL, |
||
| 76 | +146 |
- )+ xticks = NULL, |
|
| 77 | +147 |
- }+ xlab = "Days", |
| 1 | +148 |
- #' Count number of patients with missed doses by thresholds+ yval = c("Survival", "Failure"),
|
||
| 2 | +149 |
- #'+ ylab = paste(yval, "Probability"), |
||
| 3 | +150 |
- #' @description `r lifecycle::badge("stable")`
+ ylim = NULL, |
||
| 4 | +151 |
- #'+ title = NULL, |
||
| 5 | +152 |
- #' The analyze function creates a layout element to calculate cumulative counts of patients with number of missed+ footnotes = NULL, |
||
| 6 | +153 |
- #' doses at least equal to user-specified threshold values.+ font_size = 10, |
||
| 7 | +154 |
- #'+ ci_ribbon = FALSE, |
||
| 8 | +155 |
- #' This function analyzes numeric variable `vars`, a variable with numbers of missed doses,+ annot_at_risk = TRUE, |
||
| 9 | +156 |
- #' against the threshold values supplied to the `thresholds` argument as a numeric vector. This function+ annot_at_risk_title = TRUE, |
||
| 10 | +157 |
- #' assumes that every row of the given data frame corresponds to a unique patient.+ annot_surv_med = TRUE, |
||
| 11 | +158 |
- #'+ annot_coxph = FALSE, |
||
| 12 | +159 |
- #' @inheritParams s_count_cumulative+ annot_stats = NULL, |
||
| 13 | +160 |
- #' @inheritParams argument_convention+ annot_stats_vlines = FALSE, |
||
| 14 | +161 |
- #' @param thresholds (`numeric`)\cr minimum number of missed doses the patients had.+ control_coxph_pw = control_coxph(), |
||
| 15 | +162 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ ref_group_coxph = NULL, |
||
| 16 | +163 |
- #'+ control_annot_surv_med = control_surv_med_annot(), |
||
| 17 | +164 |
- #' Options are: ``r shQuote(get_stats("count_missed_doses"))``
+ control_annot_coxph = control_coxph_annot(), |
||
| 18 | +165 |
- #'+ legend_pos = NULL, |
||
| 19 | +166 |
- #' @seealso+ rel_height_plot = 0.75, |
||
| 20 | +167 |
- #' * Relevant description function [d_count_missed_doses()] which generates labels for [count_missed_doses()].+ ggtheme = NULL, |
||
| 21 | +168 |
- #' * Similar analyze function [count_cumulative()] which more generally counts cumulative values and has more+ as_list = FALSE, |
||
| 22 | +169 |
- #' options for threshold handling, but uses different labels.+ draw = lifecycle::deprecated(), |
||
| 23 | +170 |
- #'+ newpage = lifecycle::deprecated(), |
||
| 24 | +171 |
- #' @name count_missed_doses+ gp = lifecycle::deprecated(), |
||
| 25 | +172 |
- #' @order 1+ vp = lifecycle::deprecated(), |
||
| 26 | +173 |
- NULL+ name = lifecycle::deprecated(), |
||
| 27 | +174 |
-
+ annot_coxph_ref_lbls = lifecycle::deprecated(), |
||
| 28 | +175 |
- #' @describeIn count_missed_doses Statistics function to count non-missing values.+ position_coxph = lifecycle::deprecated(), |
||
| 29 | +176 |
- #'+ position_surv_med = lifecycle::deprecated(), |
||
| 30 | +177 |
- #' @return+ width_annots = lifecycle::deprecated()) {
|
||
| 31 | +178 |
- #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`.+ # Deprecated argument warnings |
||
| 32 | -+ | |||
| 179 | +10x |
- #'+ if (lifecycle::is_present(draw)) {
|
||
| 33 | -+ | |||
| 180 | +1x |
- #' @keywords internal+ lifecycle::deprecate_warn( |
||
| 34 | -+ | |||
| 181 | +1x |
- s_count_nonmissing <- function(x) {
+ "0.9.4", "g_km(draw)", |
||
| 35 | -9x | +182 | +1x |
- list(n = n_available(x))+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
| 36 | +183 |
- }+ ) |
||
| 37 | +184 |
-
+ } |
||
| 38 | -+ | |||
| 185 | +10x |
- #' Description function that calculates labels for `s_count_missed_doses()`+ if (lifecycle::is_present(newpage)) {
|
||
| 39 | -+ | |||
| 186 | +1x |
- #'+ lifecycle::deprecate_warn( |
||
| 40 | -+ | |||
| 187 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ "0.9.4", "g_km(newpage)", |
||
| 41 | -+ | |||
| 188 | +1x |
- #'+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 42 | +189 |
- #' @inheritParams s_count_missed_doses+ ) |
||
| 43 | +190 |
- #'+ } |
||
| 44 | -+ | |||
| 191 | +10x |
- #' @return [d_count_missed_doses()] returns a named `character` vector with the labels.+ if (lifecycle::is_present(gp)) {
|
||
| 45 | -+ | |||
| 192 | +1x |
- #'+ lifecycle::deprecate_warn( |
||
| 46 | -+ | |||
| 193 | +1x |
- #' @seealso [s_count_missed_doses()]+ "0.9.4", "g_km(gp)", |
||
| 47 | -+ | |||
| 194 | +1x |
- #'+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 48 | +195 |
- #' @export+ ) |
||
| 49 | +196 |
- d_count_missed_doses <- function(thresholds) {
+ } |
||
| 50 | -8x | +197 | +10x |
- paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
+ if (lifecycle::is_present(vp)) {
|
| 51 | -+ | |||
| 198 | +1x |
- }+ lifecycle::deprecate_warn( |
||
| 52 | -+ | |||
| 199 | +1x |
-
+ "0.9.4", "g_km(vp)", |
||
| 53 | -+ | |||
| 200 | +1x |
- #' @describeIn count_missed_doses Statistics function to count patients with missed doses.+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 54 | +201 |
- #'+ ) |
||
| 55 | +202 |
- #' @return+ } |
||
| 56 | -+ | |||
| 203 | +10x |
- #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold.+ if (lifecycle::is_present(name)) {
|
||
| 57 | -+ | |||
| 204 | +1x |
- #'+ lifecycle::deprecate_warn( |
||
| 58 | -+ | |||
| 205 | +1x |
- #' @keywords internal+ "0.9.4", "g_km(name)", |
||
| 59 | -+ | |||
| 206 | +1x |
- s_count_missed_doses <- function(x,+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 60 | +207 |
- thresholds,+ ) |
||
| 61 | +208 |
- .N_col, # nolint+ } |
||
| 62 | -+ | |||
| 209 | +10x |
- .N_row, # nolint+ if (lifecycle::is_present(annot_coxph_ref_lbls)) {
|
||
| 63 | -+ | |||
| 210 | +1x |
- denom = c("N_col", "n", "N_row")) {
+ lifecycle::deprecate_warn( |
||
| 64 | +211 | 1x |
- stat <- s_count_cumulative(+ "0.9.4", "g_km(annot_coxph_ref_lbls)", |
|
| 65 | +212 | 1x |
- x = x,+ details = "Please specify this setting using the 'ref_lbls' element of control_annot_coxph." |
|
| 66 | -1x | +|||
| 213 | +
- thresholds = thresholds,+ ) |
|||
| 67 | +214 | 1x |
- lower_tail = FALSE,+ control_annot_coxph[["ref_lbls"]] <- annot_coxph_ref_lbls+ |
+ |
| 215 | ++ |
+ } |
||
| 68 | -1x | +216 | +10x |
- include_eq = TRUE,+ if (lifecycle::is_present(position_coxph)) {
|
| 69 | +217 | 1x |
- .N_col = .N_col,+ lifecycle::deprecate_warn( |
|
| 70 | +218 | 1x |
- .N_row = .N_row,+ "0.9.4", "g_km(position_coxph)", |
|
| 71 | +219 | 1x |
- denom = denom+ details = "Please specify this setting using the 'x' and 'y' elements of control_annot_coxph." |
|
| 72 | +220 |
- )+ ) |
||
| 73 | +221 | 1x |
- labels <- d_count_missed_doses(thresholds)+ control_annot_coxph[["x"]] <- position_coxph[1] |
|
| 74 | +222 | 1x |
- for (i in seq_along(stat$count_fraction)) {
- |
- |
| 75 | -2x | -
- stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])+ control_annot_coxph[["y"]] <- position_coxph[2] |
||
| 76 | +223 |
} |
||
| 77 | +224 | +10x | +
+ if (lifecycle::is_present(position_surv_med)) {
+ |
+ |
| 225 | 1x |
- n_stat <- s_count_nonmissing(x)+ lifecycle::deprecate_warn( |
||
| 78 | +226 | 1x |
- c(n_stat, stat)+ "0.9.4", "g_km(position_surv_med)", |
|
| 79 | -+ | |||
| 227 | +1x |
- }+ details = "Please specify this setting using the 'x' and 'y' elements of control_annot_surv_med." |
||
| 80 | +228 |
-
+ ) |
||
| 81 | -+ | |||
| 229 | +1x |
- #' @describeIn count_missed_doses Formatted analysis function which is used as `afun`+ control_annot_surv_med[["x"]] <- position_surv_med[1] |
||
| 82 | -+ | |||
| 230 | +1x |
- #' in `count_missed_doses()`.+ control_annot_surv_med[["y"]] <- position_surv_med[2] |
||
| 83 | +231 |
- #'+ } |
||
| 84 | -+ | |||
| 232 | +10x |
- #' @return+ if (lifecycle::is_present(width_annots)) {
|
||
| 85 | -+ | |||
| 233 | +1x |
- #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()].+ lifecycle::deprecate_warn( |
||
| 86 | -+ | |||
| 234 | +1x |
- #'+ "0.9.4", "g_km(width_annots)", |
||
| 87 | -+ | |||
| 235 | +1x |
- #' @keywords internal+ details = paste( |
||
| 88 | -+ | |||
| 236 | +1x |
- a_count_missed_doses <- make_afun(+ "Please specify widths of annotation tables relative to the plot area using the 'w' element of", |
||
| 89 | -+ | |||
| 237 | +1x |
- s_count_missed_doses,+ "control_annot_surv_med (for surv_med) and control_annot_coxph (for coxph)." |
||
| 90 | +238 |
- .formats = c(n = "xx", count_fraction = format_count_fraction)+ ) |
||
| 91 | +239 |
- )+ ) |
||
| 92 | -+ | |||
| 240 | +1x |
-
+ control_annot_surv_med[["w"]] <- as.numeric(width_annots[["surv_med"]]) |
||
| 93 | -+ | |||
| 241 | +1x |
- #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments+ control_annot_coxph[["w"]] <- as.numeric(width_annots[["coxph"]]) |
||
| 94 | +242 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ } |
||
| 95 | +243 |
- #'+ |
||
| 96 | -+ | |||
| 244 | +10x |
- #' @return+ checkmate::assert_list(variables) |
||
| 97 | -+ | |||
| 245 | +10x |
- #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions,+ checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
|
||
| 98 | -+ | |||
| 246 | +10x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ checkmate::assert_logical(censor_show, len = 1) |
||
| 99 | -+ | |||
| 247 | +10x |
- #' the statistics from `s_count_missed_doses()` to the table layout.+ checkmate::assert_numeric(size, len = 1) |
||
| 100 | -+ | |||
| 248 | +10x |
- #'+ checkmate::assert_numeric(max_time, len = 1, null.ok = TRUE) |
||
| 101 | -+ | |||
| 249 | +10x |
- #' @examples+ checkmate::assert_numeric(xticks, null.ok = TRUE) |
||
| 102 | -+ | |||
| 250 | +10x |
- #' library(dplyr)+ checkmate::assert_character(xlab, len = 1, null.ok = TRUE) |
||
| 103 | -+ | |||
| 251 | +10x |
- #'+ checkmate::assert_character(yval) |
||
| 104 | -+ | |||
| 252 | +10x |
- #' anl <- tern_ex_adsl %>%+ checkmate::assert_character(ylab, null.ok = TRUE) |
||
| 105 | -+ | |||
| 253 | +10x |
- #' distinct(STUDYID, USUBJID, ARM) %>%+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
||
| 106 | -+ | |||
| 254 | +10x |
- #' mutate(+ checkmate::assert_character(title, len = 1, null.ok = TRUE) |
||
| 107 | -+ | |||
| 255 | +10x |
- #' PARAMCD = "TNDOSMIS",+ checkmate::assert_character(footnotes, len = 1, null.ok = TRUE) |
||
| 108 | -+ | |||
| 256 | +10x |
- #' PARAM = "Total number of missed doses during study",+ checkmate::assert_numeric(font_size, len = 1) |
||
| 109 | -+ | |||
| 257 | +10x |
- #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE),+ checkmate::assert_logical(ci_ribbon, len = 1) |
||
| 110 | -+ | |||
| 258 | +10x |
- #' AVALC = ""+ checkmate::assert_logical(annot_at_risk, len = 1) |
||
| 111 | -+ | |||
| 259 | +10x |
- #' )+ checkmate::assert_logical(annot_at_risk_title, len = 1) |
||
| 112 | -+ | |||
| 260 | +10x |
- #'+ checkmate::assert_logical(annot_surv_med, len = 1) |
||
| 113 | -+ | |||
| 261 | +10x |
- #' basic_table() %>%+ checkmate::assert_logical(annot_coxph, len = 1) |
||
| 114 | -+ | |||
| 262 | +10x |
- #' split_cols_by("ARM") %>%
+ checkmate::assert_subset(annot_stats, c("median", "min"))
|
||
| 115 | -+ | |||
| 263 | +10x |
- #' add_colcounts() %>%+ checkmate::assert_logical(annot_stats_vlines) |
||
| 116 | -+ | |||
| 264 | +10x |
- #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
+ checkmate::assert_list(control_coxph_pw) |
||
| 117 | -+ | |||
| 265 | +10x |
- #' build_table(anl, alt_counts_df = tern_ex_adsl)+ checkmate::assert_character(ref_group_coxph, len = 1, null.ok = TRUE) |
||
| 118 | -+ | |||
| 266 | +10x |
- #'+ checkmate::assert_list(control_annot_surv_med) |
||
| 119 | -+ | |||
| 267 | +10x |
- #' @export+ checkmate::assert_list(control_annot_coxph) |
||
| 120 | -+ | |||
| 268 | +10x |
- #' @order 2+ checkmate::assert_numeric(legend_pos, finite = TRUE, any.missing = FALSE, len = 2, null.ok = TRUE) |
||
| 121 | -+ | |||
| 269 | +10x |
- count_missed_doses <- function(lyt,+ assert_proportion_value(rel_height_plot) |
||
| 122 | -+ | |||
| 270 | +10x |
- vars,+ checkmate::assert_logical(as_list) |
||
| 123 | +271 |
- thresholds,+ |
||
| 124 | -+ | |||
| 272 | +10x |
- var_labels = vars,+ tte <- variables$tte |
||
| 125 | -+ | |||
| 273 | +10x |
- show_labels = "visible",+ is_event <- variables$is_event |
||
| 126 | -+ | |||
| 274 | +10x |
- na_str = default_na_str(),+ arm <- variables$arm |
||
| 127 | -+ | |||
| 275 | +10x |
- nested = TRUE,+ assert_valid_factor(df[[arm]]) |
||
| 128 | -+ | |||
| 276 | +10x |
- ...,+ armval <- as.character(unique(df[[arm]])) |
||
| 129 | -+ | |||
| 277 | +10x |
- table_names = vars,+ assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm)) |
||
| 130 | -+ | |||
| 278 | +10x |
- .stats = NULL,+ checkmate::assert_logical(df[[is_event]], min.len = 1) |
||
| 131 | -+ | |||
| 279 | +10x |
- .formats = NULL,+ checkmate::assert_numeric(df[[tte]], min.len = 1) |
||
| 132 | -+ | |||
| 280 | +10x |
- .labels = NULL,+ checkmate::assert_vector(col, len = length(armval), null.ok = TRUE) |
||
| 133 | -+ | |||
| 281 | +10x |
- .indent_mods = NULL) {
+ checkmate::assert_vector(lty, null.ok = TRUE) |
||
| 134 | -2x | +282 | +10x |
- extra_args <- list(thresholds = thresholds, ...)+ checkmate::assert_numeric(lwd, len = 1, null.ok = TRUE) |
| 135 | +283 | |||
| 136 | -2x | +284 | +10x |
- afun <- make_afun(+ if (annot_coxph && length(armval) < 2) {
|
| 137 | -2x | +|||
| 285 | +! |
- a_count_missed_doses,+ stop(paste( |
||
| 138 | -2x | +|||
| 286 | +! |
- .stats = .stats,+ "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`", |
||
| 139 | -2x | +|||
| 287 | +! |
- .formats = .formats,+ "in order to calculate the hazard ratio." |
||
| 140 | -2x | +|||
| 288 | +
- .labels = .labels,+ )) |
|||
| 141 | -2x | +|||
| 289 | +
- .indent_mods = .indent_mods,+ } |
|||
| 142 | -2x | +|||
| 290 | +
- .ungroup_stats = "count_fraction"+ |
|||
| 143 | +291 |
- )+ # process model |
||
| 144 | -2x | +292 | +10x |
- analyze(+ yval <- match.arg(yval) |
| 145 | -2x | +293 | +10x |
- lyt = lyt,+ formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
|
| 146 | -2x | +294 | +10x |
- vars = vars,+ fit_km <- survival::survfit( |
| 147 | -2x | +295 | +10x |
- afun = afun,+ formula = formula, |
| 148 | -2x | +296 | +10x |
- var_labels = var_labels,+ data = df, |
| 149 | -2x | +297 | +10x |
- table_names = table_names,+ conf.int = control_surv$conf_level, |
| 150 | -2x | +298 | +10x |
- show_labels = show_labels,+ conf.type = control_surv$conf_type |
| 151 | -2x | +|||
| 299 | +
- na_str = na_str,+ ) |
|||
| 152 | -2x | +300 | +10x |
- nested = nested,+ data <- h_data_plot(fit_km, armval = armval, max_time = max_time) |
| 153 | -2x | +|||
| 301 | +
- extra_args = extra_args+ |
|||
| 154 | +302 |
- )+ # calculate x-ticks |
||
| 155 | -+ | |||
| 303 | +10x |
- }+ xticks <- h_xticks(data = data, xticks = xticks, max_time = max_time) |
| 1 | +304 |
- #' Count patient events in columns+ |
||
| 2 | +305 |
- #'+ # change estimates of survival to estimates of failure (1 - survival) |
||
| 3 | -+ | |||
| 306 | +10x |
- #' @description `r lifecycle::badge("stable")`
+ if (yval == "Failure") {
|
||
| 4 | -+ | |||
| 307 | +! |
- #'+ data[c("estimate", "conf.low", "conf.high", "censor")] <- list(
|
||
| 5 | -+ | |||
| 308 | +! |
- #' The summarize function [summarize_patients_events_in_cols()] creates a layout element to summarize patient+ 1 - data$estimate, 1 - data$conf.low, 1 - data$conf.high, 1 - data$censor |
||
| 6 | +309 |
- #' event counts in columns.+ ) |
||
| 7 | +310 |
- #'+ } |
||
| 8 | +311 |
- #' This function analyzes the elements (events) supplied via the `filters_list` parameter and returns a row+ |
||
| 9 | +312 |
- #' with counts of number of patients for each event as well as the total numbers of patients and events.+ # derive y-axis limits |
||
| 10 | -+ | |||
| 313 | +10x |
- #' The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`).+ if (is.null(ylim)) {
|
||
| 11 | -+ | |||
| 314 | +10x |
- #'+ if (!is.null(max_time)) {
|
||
| 12 | -+ | |||
| 315 | +1x |
- #' If there are multiple occurrences of the same event recorded for a patient, the event is only counted once.+ y_lwr <- min(data[data$time < max_time, ][["estimate"]]) |
||
| 13 | -+ | |||
| 316 | +1x |
- #'+ y_upr <- max(data[data$time < max_time, ][["estimate"]]) |
||
| 14 | +317 |
- #' @inheritParams argument_convention+ } else {
|
||
| 15 | -+ | |||
| 318 | +9x |
- #' @param filters_list (named `list` of `character`)\cr list where each element in this list describes one+ y_lwr <- min(data[["estimate"]]) |
||
| 16 | -+ | |||
| 319 | +9x |
- #' type of event describe by filters, in the same format as [s_count_patients_with_event()].+ y_upr <- max(data[["estimate"]]) |
||
| 17 | +320 |
- #' If it has a label, then this will be used for the column title.+ } |
||
| 18 | -+ | |||
| 321 | +10x |
- #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such+ ylim <- c(y_lwr, y_upr) |
||
| 19 | +322 |
- #' that corresponding table cells will stay blank.+ } |
||
| 20 | +323 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will+ |
||
| 21 | +324 |
- #' be used as label.+ # initialize ggplot |
||
| 22 | -+ | |||
| 325 | +10x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ gg_plt <- ggplot( |
||
| 23 | -+ | |||
| 326 | +10x |
- #'+ data = data, |
||
| 24 | -+ | |||
| 327 | +10x |
- #' In addition to any statistics added using `filters_list`, statistic options are:+ mapping = aes( |
||
| 25 | -+ | |||
| 328 | +10x |
- #' ``r shQuote(get_stats("summarize_patients_events_in_cols"))``
+ x = .data[["time"]], |
||
| 26 | -+ | |||
| 329 | +10x |
- #'+ y = .data[["estimate"]], |
||
| 27 | -+ | |||
| 330 | +10x |
- #' @name count_patients_events_in_cols+ ymin = .data[["conf.low"]], |
||
| 28 | -+ | |||
| 331 | +10x |
- #' @order 1+ ymax = .data[["conf.high"]], |
||
| 29 | -+ | |||
| 332 | +10x |
- NULL+ color = .data[["strata"]], |
||
| 30 | -+ | |||
| 333 | +10x |
-
+ fill = .data[["strata"]] |
||
| 31 | +334 |
- #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple+ ) |
||
| 32 | +335 |
- #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`.+ ) + |
||
| 33 | -+ | |||
| 336 | +10x |
- #'+ theme_bw(base_size = font_size) + |
||
| 34 | -+ | |||
| 337 | +10x |
- #' @return+ scale_y_continuous(limits = ylim, expand = c(0.025, 0)) + |
||
| 35 | -+ | |||
| 338 | +10x |
- #' * `s_count_patients_and_multiple_events()` returns a list with the statistics:+ labs(title = title, x = xlab, y = ylab, caption = footnotes) + |
||
| 36 | -+ | |||
| 339 | +10x |
- #' - `unique`: number of unique patients in `df`.+ theme( |
||
| 37 | -+ | |||
| 340 | +10x |
- #' - `all`: number of rows in `df`.+ axis.text = element_text(size = font_size), |
||
| 38 | -+ | |||
| 341 | +10x |
- #' - one element with the same name as in `filters_list`: number of rows in `df`,+ axis.title = element_text(size = font_size), |
||
| 39 | -+ | |||
| 342 | +10x |
- #' i.e. events, fulfilling the filter condition.+ legend.title = element_blank(), |
||
| 40 | -+ | |||
| 343 | +10x |
- #'+ legend.text = element_text(size = font_size), |
||
| 41 | -+ | |||
| 344 | +10x |
- #' @keywords internal+ legend.box.background = element_rect(fill = "white", linewidth = 0.5), |
||
| 42 | -+ | |||
| 345 | +10x |
- s_count_patients_and_multiple_events <- function(df, # nolint+ legend.background = element_blank(), |
||
| 43 | -+ | |||
| 346 | +10x |
- id,+ legend.position = "inside", |
||
| 44 | -+ | |||
| 347 | +10x |
- filters_list,+ legend.spacing.y = unit(-0.02, "npc"),+ |
+ ||
| 348 | +10x | +
+ panel.grid.major = element_blank(),+ |
+ ||
| 349 | +10x | +
+ panel.grid.minor = element_blank() |
||
| 45 | +350 |
- empty_stats = character(),+ ) |
||
| 46 | +351 |
- labelstr = "",+ |
||
| 47 | +352 |
- custom_label = NULL) {
+ # derive x-axis limits |
||
| 48 | -9x | +353 | +10x |
- checkmate::assert_list(filters_list, names = "named")+ if (!is.null(max_time) && !is.null(xticks)) {
|
| 49 | -9x | +354 | +1x |
- checkmate::assert_data_frame(df)+ gg_plt <- gg_plt + scale_x_continuous( |
| 50 | -9x | +355 | +1x |
- checkmate::assert_string(id)+ breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))), expand = c(0.025, 0)+ |
+
| 356 | ++ |
+ ) |
||
| 51 | +357 | 9x |
- checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
+ } else if (!is.null(xticks)) {
|
|
| 52 | +358 | 9x |
- checkmate::assert_character(empty_stats)+ if (max(data$time) <= max(xticks)) {
|
|
| 53 | +359 | 9x |
- checkmate::assert_string(labelstr)+ gg_plt <- gg_plt + scale_x_continuous( |
|
| 54 | +360 | 9x |
- checkmate::assert_string(custom_label, null.ok = TRUE)+ breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)), expand = c(0.025, 0) |
|
| 55 | +361 |
-
+ ) |
||
| 56 | +362 |
- # Below we want to count each row in `df` once, therefore introducing this helper index column.+ } else {
|
||
| 57 | -9x | +|||
| 363 | +! |
- df$.row_index <- as.character(seq_len(nrow(df)))+ gg_plt <- gg_plt + scale_x_continuous(breaks = xticks, expand = c(0.025, 0)) |
||
| 58 | -9x | +|||
| 364 | +
- y <- list()+ } |
|||
| 59 | -9x | +|||
| 365 | +! |
- row_label <- if (labelstr != "") {
+ } else if (!is.null(max_time)) {
|
||
| 60 | +366 | ! |
- labelstr+ gg_plt <- gg_plt + scale_x_continuous(limits = c(0, max_time), expand = c(0.025, 0)) |
|
| 61 | -9x | +|||
| 367 | +
- } else if (!is.null(custom_label)) {
+ } |
|||
| 62 | -2x | +|||
| 368 | +
- custom_label+ |
|||
| 63 | +369 |
- } else {
+ # set legend position |
||
| 64 | -7x | +370 | +10x |
- "counts"+ if (!is.null(legend_pos)) {
|
| 65 | -+ | |||
| 371 | +2x |
- }+ gg_plt <- gg_plt + theme(legend.position.inside = legend_pos) |
||
| 66 | -9x | +|||
| 372 | +
- y$unique <- formatters::with_label(+ } else {
|
|||
| 67 | -9x | +373 | +8x |
- s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L],+ max_time2 <- sort( |
| 68 | -9x | +374 | +8x |
- row_label+ data$time, |
| 69 | -+ | |||
| 375 | +8x |
- )+ partial = nrow(data) - length(armval) - 1 |
||
| 70 | -9x | +376 | +8x |
- y$all <- formatters::with_label(+ )[nrow(data) - length(armval) - 1] |
| 71 | -9x | +|||
| 377 | +
- nrow(df),+ |
|||
| 72 | -9x | +378 | +8x |
- row_label+ y_rng <- ylim[2] - ylim[1] |
| 73 | +379 |
- )+ |
||
| 74 | -9x | +380 | +8x |
- events <- Map(+ if (yval == "Survival" && all(data$estimate[data$time == max_time2] > ylim[1] + 0.09 * y_rng) && |
| 75 | -9x | +381 | +8x |
- function(filters) {
+ all(data$estimate[data$time == max_time2] < ylim[1] + 0.5 * y_rng)) { # nolint
|
| 76 | -25x | +382 | +1x |
- formatters::with_label(+ gg_plt <- gg_plt + |
| 77 | -25x | +383 | +1x |
- s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count,+ theme( |
| 78 | -25x | +384 | +1x |
- row_label+ legend.position.inside = c(1, 0.5), |
| 79 | -+ | |||
| 385 | +1x |
- )+ legend.justification = c(1.1, 0.6) |
||
| 80 | +386 |
- },- |
- ||
| 81 | -9x | -
- filters = filters_list+ ) |
||
| 82 | +387 |
- )+ } else {
|
||
| 83 | -9x | +388 | +7x |
- y_complete <- c(y, events)+ gg_plt <- gg_plt + |
| 84 | -9x | +389 | +7x |
- y <- if (length(empty_stats) > 0) {
+ theme( |
| 85 | -3x | +390 | +7x |
- y_reduced <- y_complete+ legend.position.inside = c(1, 0), |
| 86 | -3x | +391 | +7x |
- for (stat in intersect(names(y_complete), empty_stats)) {
+ legend.justification = c(1.1, -0.4) |
| 87 | -4x | +|||
| 392 | +
- y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]]))+ ) |
|||
| 88 | +393 |
} |
||
| 89 | -3x | +|||
| 394 | +
- y_reduced+ } |
|||
| 90 | +395 |
- } else {
+
|
||
| 91 | -6x | +|||
| 396 | +
- y_complete+ # add lines |
|||
| 92 | -+ | |||
| 397 | +10x |
- }+ gg_plt <- if (is.null(lty)) {
|
||
| 93 | +398 | 9x |
- y+ gg_plt + geom_step(linewidth = lwd, na.rm = TRUE) |
|
| 94 | -+ | |||
| 399 | +10x |
- }+ } else if (length(lty) == 1) {
|
||
| 95 | -+ | |||
| 400 | +! |
-
+ gg_plt + geom_step(linewidth = lwd, lty = lty, na.rm = TRUE) |
||
| 96 | +401 |
- #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function+ } else {
|
||
| 97 | -+ | |||
| 402 | +1x |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ gg_plt + |
||
| 98 | -+ | |||
| 403 | +1x |
- #'+ geom_step(aes(lty = .data[["strata"]]), linewidth = lwd, na.rm = TRUE) + |
||
| 99 | -+ | |||
| 404 | +1x |
- #' @param col_split (`flag`)\cr whether the columns should be split.+ scale_linetype_manual(values = lty) |
||
| 100 | +405 |
- #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe.+ } |
||
| 101 | +406 |
- #'+ |
||
| 102 | +407 |
- #' @return+ # add censor marks |
||
| 103 | -+ | |||
| 408 | +10x |
- #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions,+ if (censor_show) {
|
||
| 104 | -+ | |||
| 409 | +10x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ gg_plt <- gg_plt + geom_point( |
||
| 105 | -+ | |||
| 410 | +10x |
- #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout.+ data = data[data$n.censor != 0, ], |
||
| 106 | -+ | |||
| 411 | +10x |
- #'+ aes(x = .data[["time"]], y = .data[["censor"]], shape = "Censored"), |
||
| 107 | -+ | |||
| 412 | +10x |
- #' @examples+ size = size, |
||
| 108 | -+ | |||
| 413 | +10x |
- #' df <- data.frame(+ na.rm = TRUE |
||
| 109 | +414 |
- #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
+ ) + |
||
| 110 | -+ | |||
| 415 | +10x |
- #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
+ scale_shape_manual(name = NULL, values = pch) + |
||
| 111 | -+ | |||
| 416 | +10x |
- #' AESER = rep("Y", 7),
+ guides(fill = guide_legend(override.aes = list(shape = NA))) |
||
| 112 | +417 |
- #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
+ } |
||
| 113 | +418 |
- #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
+
|
||
| 114 | +419 |
- #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
+ # add ci ribbon |
||
| 115 | -+ | |||
| 420 | +1x |
- #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
+ if (ci_ribbon) gg_plt <- gg_plt + geom_ribbon(alpha = 0.3, lty = 0, na.rm = TRUE) |
||
| 116 | +421 |
- #' )+ |
||
| 117 | +422 |
- #'+ # control aesthetics |
||
| 118 | -+ | |||
| 423 | +10x |
- #' # `summarize_patients_events_in_cols()`+ if (!is.null(col)) {
|
||
| 119 | -+ | |||
| 424 | +1x |
- #' basic_table() %>%+ gg_plt <- gg_plt + |
||
| 120 | -+ | |||
| 425 | +1x |
- #' summarize_patients_events_in_cols(+ scale_color_manual(values = col) + |
||
| 121 | -+ | |||
| 426 | +1x |
- #' filters_list = list(+ scale_fill_manual(values = col) |
||
| 122 | +427 |
- #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"),+ } |
||
| 123 | -+ | |||
| 428 | +! |
- #' fatal = c(AESDTH = "Y"),+ if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
||
| 124 | +429 |
- #' fatal_related = c(AEREL = "Y", AESDTH = "Y")+ |
||
| 125 | +430 |
- #' ),+ # annotate with stats (text/vlines) |
||
| 126 | -+ | |||
| 431 | +10x |
- #' custom_label = "%s Total number of patients and events"+ if (!is.null(annot_stats)) {
|
||
| 127 | -+ | |||
| 432 | +! |
- #' ) %>%+ if ("median" %in% annot_stats) {
|
||
| 128 | -+ | |||
| 433 | +! |
- #' build_table(df)+ fit_km_all <- survival::survfit( |
||
| 129 | -+ | |||
| 434 | +! |
- #'+ formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
|
||
| 130 | -+ | |||
| 435 | +! |
- #' @export+ data = df, |
||
| 131 | -+ | |||
| 436 | +! |
- #' @order 2+ conf.int = control_surv$conf_level, |
||
| 132 | -+ | |||
| 437 | +! |
- summarize_patients_events_in_cols <- function(lyt, # nolint+ conf.type = control_surv$conf_type |
||
| 133 | +438 |
- id = "USUBJID",+ ) |
||
| 134 | -+ | |||
| 439 | +! |
- filters_list = list(),+ gg_plt <- gg_plt + |
||
| 135 | -- |
- empty_stats = character(),+ | ||
| 440 | +! | +
+ annotate( |
||
| 136 | -+ | |||
| 441 | +! |
- na_str = default_na_str(),+ "text", |
||
| 137 | -+ | |||
| 442 | +! |
- ...,+ size = font_size / .pt, col = 1, lineheight = 0.95, |
||
| 138 | -+ | |||
| 443 | +! |
- .stats = c(+ x = stats::median(fit_km_all) + 0.07 * max(data$time), |
||
| 139 | -+ | |||
| 444 | +! |
- "unique",+ y = ifelse(yval == "Survival", 0.65, 0.35), |
||
| 140 | -+ | |||
| 445 | +! |
- "all",+ label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
|
||
| 141 | +446 |
- names(filters_list)+ ) |
||
| 142 | -+ | |||
| 447 | +! |
- ),+ if (annot_stats_vlines) {
|
||
| 143 | -+ | |||
| 448 | +! |
- .labels = c(+ gg_plt <- gg_plt + |
||
| 144 | -+ | |||
| 449 | +! |
- unique = "Patients (All)",+ annotate( |
||
| 145 | -+ | |||
| 450 | +! |
- all = "Events (All)",+ "segment",+ |
+ ||
| 451 | +! | +
+ x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf,+ |
+ ||
| 452 | +! | +
+ linetype = 2, col = "darkgray" |
||
| 146 | +453 |
- labels_or_names(filters_list)+ ) |
||
| 147 | +454 |
- ),+ } |
||
| 148 | +455 |
- col_split = TRUE) {
+ } |
||
| 149 | -2x | +|||
| 456 | +! |
- extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...)+ if ("min" %in% annot_stats) {
|
||
| 150 | -+ | |||
| 457 | +! |
-
+ min_fu <- min(df[[tte]]) |
||
| 151 | -2x | +|||
| 458 | +! |
- afun_list <- Map(+ gg_plt <- gg_plt + |
||
| 152 | -2x | +|||
| 459 | +! |
- function(stat) {
+ annotate( |
||
| 153 | -7x | +|||
| 460 | +! |
- make_afun(+ "text", |
||
| 154 | -7x | +|||
| 461 | +! |
- s_count_patients_and_multiple_events,+ size = font_size / .pt, col = 1, lineheight = 0.95, |
||
| 155 | -7x | +|||
| 462 | +! |
- .stats = stat,+ x = min_fu + max(data$time) * 0.07, |
||
| 156 | -7x | +|||
| 463 | +! |
- .formats = "xx."+ y = ifelse(yval == "Survival", 0.96, 0.05), |
||
| 157 | -+ | |||
| 464 | +! |
- )+ label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
|
||
| 158 | +465 |
- },+ ) |
||
| 159 | -2x | +|||
| 466 | +! |
- stat = .stats+ if (annot_stats_vlines) {
|
||
| 160 | -+ | |||
| 467 | +! |
- )+ gg_plt <- gg_plt + |
||
| 161 | -2x | +|||
| 468 | +! |
- if (col_split) {
+ annotate( |
||
| 162 | -2x | +|||
| 469 | +! |
- lyt <- split_cols_by_multivar(+ "segment", |
||
| 163 | -2x | +|||
| 470 | +! |
- lyt = lyt,+ linetype = 2, col = "darkgray", |
||
| 164 | -2x | +|||
| 471 | +! |
- vars = rep(id, length(.stats)),+ x = min_fu, xend = min_fu, y = Inf, yend = -Inf |
||
| 165 | -2x | +|||
| 472 | +
- varlabels = .labels[.stats]+ ) |
|||
| 166 | +473 |
- )+ } |
||
| 167 | +474 | ++ |
+ }+ |
+ |
| 475 | +! | +
+ gg_plt <- gg_plt + guides(fill = guide_legend(override.aes = list(shape = NA, label = "")))+ |
+ ||
| 476 |
} |
|||
| 168 | -2x | +|||
| 477 | +
- summarize_row_groups(+ |
|||
| 169 | -2x | +|||
| 478 | +
- lyt = lyt,+ # add at risk annotation table |
|||
| 170 | -2x | +479 | +10x |
- cfun = afun_list,+ if (annot_at_risk) {
|
| 171 | -2x | +480 | +9x |
- na_str = na_str,+ annot_tbl <- summary(fit_km, times = xticks, extend = TRUE) |
| 172 | -2x | +481 | +9x |
- extra_args = extra_args+ annot_tbl <- if (is.null(fit_km$strata)) {
|
| 173 | -+ | |||
| 482 | +! |
- )+ data.frame( |
||
| 174 | -+ | |||
| 483 | +! |
- }+ n.risk = annot_tbl$n.risk, |
| 1 | -+ | |||
| 484 | +! |
- #' Univariate formula special term+ time = annot_tbl$time, |
||
| 2 | -+ | |||
| 485 | +! |
- #'+ strata = armval |
||
| 3 | +486 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 4 | +487 |
- #'+ } else {
|
||
| 5 | -+ | |||
| 488 | +9x |
- #' The special term `univariate` indicate that the model should be fitted individually for+ strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
||
| 6 | -+ | |||
| 489 | +9x |
- #' every variable included in univariate.+ levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 7 | -+ | |||
| 490 | +9x |
- #'+ data.frame( |
||
| 8 | -+ | |||
| 491 | +9x |
- #' @param x (`character`)\cr a vector of variable names separated by commas.+ n.risk = annot_tbl$n.risk, |
||
| 9 | -+ | |||
| 492 | +9x |
- #'+ time = annot_tbl$time, |
||
| 10 | -+ | |||
| 493 | +9x |
- #' @return When used within a model formula, produces univariate models for each variable provided.+ strata = annot_tbl$strata |
||
| 11 | +494 |
- #'+ ) |
||
| 12 | +495 |
- #' @details+ } |
||
| 13 | +496 |
- #' If provided alongside with pairwise specification, the model+ |
||
| 14 | -+ | |||
| 497 | +9x |
- #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models+ at_risk_tbl <- as.data.frame(tidyr::pivot_wider(annot_tbl, names_from = "time", values_from = "n.risk")[, -1]) |
||
| 15 | -+ | |||
| 498 | +9x |
- #' + `y ~ ARM`+ at_risk_tbl[is.na(at_risk_tbl)] <- 0 |
||
| 16 | -+ | |||
| 499 | +9x |
- #' + `y ~ ARM + SEX`+ rownames(at_risk_tbl) <- levels(annot_tbl$strata) |
||
| 17 | +500 |
- #' + `y ~ ARM + AGE`+ |
||
| 18 | -+ | |||
| 501 | +9x |
- #' + `y ~ ARM + RACE`+ gg_at_risk <- df2gg( |
||
| 19 | -+ | |||
| 502 | +9x |
- #'+ at_risk_tbl, |
||
| 20 | -+ | |||
| 503 | +9x |
- #' @export+ font_size = font_size, col_labels = FALSE, hline = FALSE,+ |
+ ||
| 504 | +9x | +
+ colwidths = rep(1, ncol(at_risk_tbl)) |
||
| 21 | +505 |
- univariate <- function(x) {
+ ) + |
||
| 22 | -2x | +506 | +9x |
- structure(x, varname = deparse(substitute(x)))+ labs(title = if (annot_at_risk_title) "Patients at Risk:" else NULL, x = xlab) + |
| 23 | -+ | |||
| 507 | +9x |
- }+ theme_bw(base_size = font_size) + |
||
| 24 | -+ | |||
| 508 | +9x |
-
+ theme( |
||
| 25 | -+ | |||
| 509 | +9x |
- # Get the right-hand-term of a formula+ plot.title = element_text(size = font_size, vjust = 3, face = "bold"), |
||
| 26 | -+ | |||
| 510 | +9x |
- rht <- function(x) {
+ panel.border = element_blank(), |
||
| 27 | -4x | +511 | +9x |
- checkmate::assert_formula(x)+ panel.grid = element_blank(), |
| 28 | -4x | +512 | +9x |
- y <- as.character(rev(x)[[1]])+ axis.title.y = element_blank(), |
| 29 | -4x | +513 | +9x |
- return(y)+ axis.ticks.y = element_blank(), |
| 30 | -+ | |||
| 514 | +9x |
- }+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
||
| 31 | -+ | |||
| 515 | +9x |
-
+ axis.text.x = element_text(size = font_size), |
||
| 32 | -+ | |||
| 516 | +9x |
- #' Hazard ratio estimation in interactions+ axis.line.x = element_line() |
||
| 33 | +517 |
- #'+ ) + |
||
| 34 | -+ | |||
| 518 | +9x |
- #' This function estimates the hazard ratios between arms when an interaction variable is given with+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(at_risk_tbl))) |
||
| 35 | -+ | |||
| 519 | +9x |
- #' specific values.+ gg_at_risk <- suppressMessages( |
||
| 36 | -+ | |||
| 520 | +9x |
- #'+ gg_at_risk + |
||
| 37 | -+ | |||
| 521 | +9x |
- #' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of+ scale_x_continuous(expand = c(0.025, 0), breaks = seq_along(at_risk_tbl) - 0.5, labels = xticks) + |
||
| 38 | -+ | |||
| 522 | +9x |
- #' the levels of `variable` given the levels of `given`.+ scale_y_continuous(labels = rev(levels(annot_tbl$strata)), breaks = seq_len(nrow(at_risk_tbl))) |
||
| 39 | +523 |
- #' @param lvl_var,lvl_given (`character`)\cr corresponding levels given by [levels()].+ ) |
||
| 40 | +524 |
- #' @param mmat (named `numeric`) a vector filled with `0`s used as a template to obtain the design matrix.+ |
||
| 41 | -+ | |||
| 525 | +9x |
- #' @param coef (`numeric`)\cr vector of estimated coefficients.+ if (!as_list) {
|
||
| 42 | -+ | |||
| 526 | +8x |
- #' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model.+ gg_plt <- cowplot::plot_grid( |
||
| 43 | -+ | |||
| 527 | +8x |
- #' @param conf_level (`proportion`)\cr confidence level of estimate intervals.+ gg_plt, |
||
| 44 | -+ | |||
| 528 | +8x |
- #'+ gg_at_risk, |
||
| 45 | -+ | |||
| 529 | +8x |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ align = "v", |
||
| 46 | -+ | |||
| 530 | +8x |
- #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.+ axis = "tblr", |
||
| 47 | -+ | |||
| 531 | +8x |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ ncol = 1, |
||
| 48 | -+ | |||
| 532 | +8x |
- #'+ rel_heights = c(rel_height_plot, 1 - rel_height_plot) |
||
| 49 | +533 |
- #' - b1 (arm b), b2 (arm c)+ ) |
||
| 50 | +534 |
- #' - b3 (sex m)+ } |
||
| 51 | +535 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ } |
||
| 52 | +536 |
- #'+ |
||
| 53 | +537 |
- #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation+ # add median survival time annotation table |
||
| 54 | -+ | |||
| 538 | +10x |
- #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),+ if (annot_surv_med) {
|
||
| 55 | -+ | |||
| 539 | +8x |
- #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained+ surv_med_tbl <- h_tbl_median_surv(fit_km = fit_km, armval = armval) |
||
| 56 | -+ | |||
| 540 | +8x |
- #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.+ bg_fill <- if (isTRUE(control_annot_surv_med[["fill"]])) "#00000020" else control_annot_surv_med[["fill"]] |
||
| 57 | +541 |
- #'+ |
||
| 58 | -+ | |||
| 542 | +8x |
- #' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of+ gg_surv_med <- df2gg(surv_med_tbl, font_size = font_size, colwidths = c(1, 1, 2), bg_fill = bg_fill) + |
||
| 59 | -+ | |||
| 543 | +8x |
- #' `variable` and `given`, with columns:+ theme( |
||
| 60 | -+ | |||
| 544 | +8x |
- #' * `coef_hat`: Estimation of the coefficient.+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
||
| 61 | -+ | |||
| 545 | +8x |
- #' * `coef_se`: Standard error of the estimation.+ plot.margin = margin(0, 2, 0, 5) |
||
| 62 | +546 |
- #' * `hr`: Hazard ratio.+ ) + |
||
| 63 | -+ | |||
| 547 | +8x |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(surv_med_tbl) + 1.5)) |
||
| 64 | -+ | |||
| 548 | +8x |
- #'+ gg_surv_med <- suppressMessages( |
||
| 65 | -+ | |||
| 549 | +8x |
- #' @seealso [s_cox_multivariate()].+ gg_surv_med + |
||
| 66 | -+ | |||
| 550 | +8x |
- #'+ scale_x_continuous(expand = c(0.025, 0)) + |
||
| 67 | -+ | |||
| 551 | +8x |
- #' @examples+ scale_y_continuous(labels = rev(rownames(surv_med_tbl)), breaks = seq_len(nrow(surv_med_tbl))) |
||
| 68 | +552 |
- #' library(dplyr)+ ) |
||
| 69 | +553 |
- #' library(survival)+ |
||
| 70 | -+ | |||
| 554 | +8x |
- #'+ gg_plt <- cowplot::ggdraw(gg_plt) + |
||
| 71 | -+ | |||
| 555 | +8x |
- #' ADSL <- tern_ex_adsl %>%+ cowplot::draw_plot( |
||
| 72 | -+ | |||
| 556 | +8x |
- #' filter(SEX %in% c("F", "M"))
+ gg_surv_med, |
||
| 73 | -+ | |||
| 557 | +8x |
- #'+ control_annot_surv_med[["x"]], |
||
| 74 | -+ | |||
| 558 | +8x |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")+ control_annot_surv_med[["y"]], |
||
| 75 | -+ | |||
| 559 | +8x |
- #' adtte$ARMCD <- droplevels(adtte$ARMCD)+ width = control_annot_surv_med[["w"]], |
||
| 76 | -+ | |||
| 560 | +8x |
- #' adtte$SEX <- droplevels(adtte$SEX)+ height = control_annot_surv_med[["h"]], |
||
| 77 | -+ | |||
| 561 | +8x |
- #'+ vjust = 0.5, |
||
| 78 | -+ | |||
| 562 | +8x |
- #' mod <- coxph(+ hjust = 0.5 |
||
| 79 | +563 |
- #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,+ ) |
||
| 80 | +564 |
- #' data = adtte+ } |
||
| 81 | +565 |
- #' )+ |
||
| 82 | +566 |
- #'+ # add coxph annotation table |
||
| 83 | -+ | |||
| 567 | +10x |
- #' mmat <- stats::model.matrix(mod)[1, ]+ if (annot_coxph) {
|
||
| 84 | -+ | |||
| 568 | +1x |
- #' mmat[!mmat == 0] <- 0+ coxph_tbl <- h_tbl_coxph_pairwise( |
||
| 85 | -+ | |||
| 569 | +1x |
- #'+ df = df, |
||
| 86 | -+ | |||
| 570 | +1x |
- #' @keywords internal+ variables = variables, |
||
| 87 | -+ | |||
| 571 | +1x |
- estimate_coef <- function(variable, given,+ ref_group_coxph = ref_group_coxph, |
||
| 88 | -+ | |||
| 572 | +1x |
- lvl_var, lvl_given,+ control_coxph_pw = control_coxph_pw, |
||
| 89 | -+ | |||
| 573 | +1x |
- coef,+ annot_coxph_ref_lbls = control_annot_coxph[["ref_lbls"]] |
||
| 90 | +574 |
- mmat,+ ) |
||
| 91 | -+ | |||
| 575 | +1x |
- vcov,+ bg_fill <- if (isTRUE(control_annot_coxph[["fill"]])) "#00000020" else control_annot_coxph[["fill"]] |
||
| 92 | +576 |
- conf_level = 0.95) {
+
|
||
| 93 | -8x | +577 | +1x |
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ gg_coxph <- df2gg(coxph_tbl, font_size = font_size, colwidths = c(1.1, 1, 3), bg_fill = bg_fill) + |
| 94 | -8x | +578 | +1x |
- giv_lvl <- paste0(given, lvl_given)+ theme( |
| 95 | -+ | |||
| 579 | +1x |
-
+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
||
| 96 | -8x | +580 | +1x |
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ plot.margin = margin(0, 2, 0, 5) |
| 97 | -8x | +|||
| 581 | +
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ ) + |
|||
| 98 | -8x | +582 | +1x |
- design_mat <- within(+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(coxph_tbl) + 1.5)) |
| 99 | -8x | +583 | +1x |
- data = design_mat,+ gg_coxph <- suppressMessages( |
| 100 | -8x | +584 | +1x |
- expr = {
+ gg_coxph + |
| 101 | -8x | +585 | +1x |
- inter <- paste0(variable, ":", given)+ scale_x_continuous(expand = c(0.025, 0)) + |
| 102 | -8x | +586 | +1x |
- rev_inter <- paste0(given, ":", variable)+ scale_y_continuous(labels = rev(rownames(coxph_tbl)), breaks = seq_len(nrow(coxph_tbl))) |
| 103 | +587 |
- }+ ) |
||
| 104 | +588 |
- )+ |
||
| 105 | -+ | |||
| 589 | +1x |
-
+ gg_plt <- cowplot::ggdraw(gg_plt) + |
||
| 106 | -8x | +590 | +1x |
- split_by_variable <- design_mat$variable+ cowplot::draw_plot( |
| 107 | -8x | +591 | +1x |
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ gg_coxph, |
| 108 | -+ | |||
| 592 | +1x |
-
+ control_annot_coxph[["x"]], |
||
| 109 | -8x | +593 | +1x |
- design_mat <- apply(+ control_annot_coxph[["y"]], |
| 110 | -8x | +594 | +1x |
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ width = control_annot_coxph[["w"]], |
| 111 | -27x | +595 | +1x |
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ height = control_annot_coxph[["h"]], |
| 112 | -27x | +596 | +1x |
- return(mmat)+ vjust = 0.5, |
| 113 | -+ | |||
| 597 | +1x |
- }+ hjust = 0.5 |
||
| 114 | +598 |
- )- |
- ||
| 115 | -8x | -
- colnames(design_mat) <- interaction_names+ ) |
||
| 116 | +599 | - - | -||
| 117 | -8x | -
- betas <- as.matrix(coef)+ } |
||
| 118 | +600 | |||
| 119 | -8x | +601 | +10x |
- coef_hat <- t(design_mat) %*% betas+ if (as_list) {
|
| 120 | -8x | +602 | +1x |
- dimnames(coef_hat)[2] <- "coef"+ list(plot = gg_plt, table = gg_at_risk) |
| 121 | +603 | - - | -||
| 122 | -8x | -
- coef_se <- apply(design_mat, 2, function(x) {
- |
- ||
| 123 | -27x | -
- vcov_el <- as.logical(x)+ } else {
|
||
| 124 | -27x | +604 | +9x |
- y <- vcov[vcov_el, vcov_el]+ gg_plt |
| 125 | -27x | +|||
| 605 | +
- y <- sum(y)+ } |
|||
| 126 | -27x | +|||
| 606 | +
- y <- sqrt(y)+ } |
|||
| 127 | -27x | +
| 1 | +
- return(y)+ #' Count number of patients and sum exposure across all patients in columns |
|||
| 128 | +2 |
- })+ #' |
||
| 129 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 130 | -8x | +|||
| 4 | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ #' |
|||
| 131 | -8x | +|||
| 5 | +
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ #' The analyze function [analyze_patients_exposure_in_cols()] creates a layout element to count total numbers of |
|||
| 132 | +6 |
-
+ #' patients and sum an analysis value (i.e. exposure) across all patients in columns. |
||
| 133 | -8x | +|||
| 7 | +
- y <- apply(y, 1, function(x) {
+ #' |
|||
| 134 | -27x | +|||
| 8 | +
- x["hr"] <- exp(x["coef"])+ #' The primary analysis variable `ex_var` is the exposure variable used to calculate the `sum_exposure` statistic. The |
|||
| 135 | -27x | +|||
| 9 | +
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ #' `id` variable is used to uniquely identify patients in the data such that only unique patients are counted in the |
|||
| 136 | -27x | +|||
| 10 | +
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ #' `n_patients` statistic, and the `var` variable is used to create a row split if needed. The percentage returned as |
|||
| 137 | +11 |
-
+ #' part of the `n_patients` statistic is the proportion of all records that correspond to a unique patient. |
||
| 138 | -27x | +|||
| 12 | +
- return(x)+ #' |
|||
| 139 | +13 |
- })+ #' The summarize function [summarize_patients_exposure_in_cols()] performs the same function as |
||
| 140 | +14 |
-
+ #' [analyze_patients_exposure_in_cols()] except it creates content rows, not data rows, to summarize the current table |
||
| 141 | -8x | +|||
| 15 | +
- y <- t(y)+ #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
|||
| 142 | -8x | +|||
| 16 | +
- y <- by(y, split_by_variable, identity)+ #' occurred. |
|||
| 143 | -8x | +|||
| 17 | +
- y <- lapply(y, as.matrix)+ #' |
|||
| 144 | +18 |
-
+ #' If a column split has not yet been performed in the table, `col_split` must be set to `TRUE` for the first call of |
||
| 145 | -8x | +|||
| 19 | +
- attr(y, "details") <- paste0(+ #' [analyze_patients_exposure_in_cols()] or [summarize_patients_exposure_in_cols()]. |
|||
| 146 | -8x | +|||
| 20 | +
- "Estimations of ", variable,+ #' |
|||
| 147 | -8x | +|||
| 21 | +
- " hazard ratio given the level of ", given, " compared to ",+ #' @inheritParams argument_convention |
|||
| 148 | -8x | +|||
| 22 | +
- variable, " level ", lvl_var[1], "."+ #' @param ex_var (`string`)\cr name of the variable in `df` containing exposure values. |
|||
| 149 | +23 |
- )+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty, this will be used as label. |
||
| 150 | -8x | +|||
| 24 | +
- return(y)+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 151 | +25 |
- }+ #' |
||
| 152 | +26 |
-
+ #' Options are: ``r shQuote(get_stats("analyze_patients_exposure_in_cols"))``
|
||
| 153 | +27 |
- #' `tryCatch` around `car::Anova`+ #' |
||
| 154 | +28 |
- #'+ #' @name summarize_patients_exposure_in_cols |
||
| 155 | +29 |
- #' Captures warnings when executing [car::Anova].+ #' @order 1 |
||
| 156 | +30 |
- #'+ NULL |
||
| 157 | +31 |
- #' @inheritParams car::Anova+ |
||
| 158 | +32 |
- #'+ #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers |
||
| 159 | +33 |
- #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings.+ #' of patients and the sum of exposure across all patients. |
||
| 160 | +34 |
#' |
||
| 161 | +35 |
- #' @examples+ #' @return |
||
| 162 | +36 |
- #' # `car::Anova` on cox regression model including strata and expected+ #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics: |
||
| 163 | +37 |
- #' # a likelihood ratio test triggers a warning as only Wald method is+ #' * `n_patients`: Number of unique patients in `df`. |
||
| 164 | +38 |
- #' # accepted.+ #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`. |
||
| 165 | +39 |
#' |
||
| 166 | +40 |
- #' library(survival)+ #' @keywords internal |
||
| 167 | +41 |
- #'+ s_count_patients_sum_exposure <- function(df, |
||
| 168 | +42 |
- #' mod <- coxph(+ ex_var = "AVAL", |
||
| 169 | +43 |
- #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),+ id = "USUBJID", |
||
| 170 | +44 |
- #' data = ovarian+ labelstr = "", |
||
| 171 | +45 |
- #' )+ .stats = c("n_patients", "sum_exposure"),
|
||
| 172 | +46 |
- #'+ .N_col, # nolint |
||
| 173 | +47 |
- #' @keywords internal+ custom_label = NULL) {
|
||
| 174 | -+ | |||
| 48 | +56x |
- try_car_anova <- function(mod,+ assert_df_with_variables(df, list(ex_var = ex_var, id = id)) |
||
| 175 | -+ | |||
| 49 | +56x |
- test.statistic) { # nolint
+ checkmate::assert_string(id) |
||
| 176 | -2x | +50 | +56x |
- y <- tryCatch(+ checkmate::assert_string(labelstr) |
| 177 | -2x | +51 | +56x |
- withCallingHandlers(+ checkmate::assert_string(custom_label, null.ok = TRUE) |
| 178 | -2x | +52 | +56x |
- expr = {
+ checkmate::assert_numeric(df[[ex_var]]) |
| 179 | -2x | +53 | +56x |
- warn_text <- c()+ checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
|
| 180 | -2x | +|||
| 54 | +
- list(+ |
|||
| 181 | -2x | +55 | +56x |
- aov = car::Anova(+ row_label <- if (labelstr != "") {
|
| 182 | -2x | +|||
| 56 | +! |
- mod,+ labelstr |
||
| 183 | -2x | +57 | +56x |
- test.statistic = test.statistic,+ } else if (!is.null(custom_label)) {
|
| 184 | -2x | +58 | +48x |
- type = "III"+ custom_label |
| 185 | +59 |
- ),+ } else {
|
||
| 186 | -2x | +60 | +8x |
- warn_text = warn_text+ "Total patients numbers/person time" |
| 187 | +61 |
- )+ } |
||
| 188 | +62 |
- },+ |
||
| 189 | -2x | +63 | +56x |
- warning = function(w) {
+ y <- list() |
| 190 | +64 |
- # If a warning is detected it is handled as "w".+ |
||
| 191 | -! | +|||
| 65 | +56x |
- warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
+ if ("n_patients" %in% .stats) {
|
||
| 192 | -+ | |||
| 66 | +23x |
-
+ y$n_patients <- |
||
| 193 | -+ | |||
| 67 | +23x |
- # A warning is sometimes expected, then, we want to restart+ formatters::with_label( |
||
| 194 | -+ | |||
| 68 | +23x |
- # the execution while ignoring the warning.+ s_num_patients_content( |
||
| 195 | -! | +|||
| 69 | +23x |
- invokeRestart("muffleWarning")
+ df = df, |
||
| 196 | -+ | |||
| 70 | +23x |
- }+ .N_col = .N_col, # nolint |
||
| 197 | -+ | |||
| 71 | +23x |
- ),+ .var = id, |
||
| 198 | -2x | +72 | +23x |
- finally = {
+ labelstr = ""+ |
+
| 73 | +23x | +
+ )$unique,+ |
+ ||
| 74 | +23x | +
+ row_label |
||
| 199 | +75 |
- }+ ) |
||
| 200 | +76 |
- )+ }+ |
+ ||
| 77 | +56x | +
+ if ("sum_exposure" %in% .stats) {
+ |
+ ||
| 78 | +34x | +
+ y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label) |
||
| 201 | +79 |
-
+ } |
||
| 202 | -2x | +80 | +56x |
- return(y)+ y |
| 203 | +81 |
} |
||
| 204 | +82 | |||
| 205 | +83 |
- #' Fit a Cox regression model and ANOVA+ #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in |
||
| 206 | +84 |
- #'+ #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in |
||
| 207 | +85 |
- #' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results.+ #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`. |
||
| 208 | +86 |
#' |
||
| 209 | +87 |
- #' @inheritParams t_coxreg+ #' @return |
||
| 210 | +88 | ++ |
+ #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()].+ |
+ |
| 89 |
#' |
|||
| 211 | +90 |
- #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and+ #' @examples |
||
| 212 | +91 |
- #' `aov` (result of [car::Anova()]).+ #' a_count_patients_sum_exposure( |
||
| 213 | +92 |
- #'+ #' df = df, |
||
| 214 | +93 |
- #' @noRd+ #' var = "SEX", |
||
| 215 | +94 |
- fit_n_aov <- function(formula,+ #' .N_col = nrow(df), |
||
| 216 | +95 |
- data = data,+ #' .stats = "n_patients" |
||
| 217 | +96 |
- conf_level = conf_level,+ #' ) |
||
| 218 | +97 |
- pval_method = c("wald", "likelihood"),
+ #' |
||
| 219 | +98 |
- ...) {
+ #' @export |
||
| 220 | -1x | +|||
| 99 | +
- pval_method <- match.arg(pval_method)+ a_count_patients_sum_exposure <- function(df, |
|||
| 221 | +100 |
-
+ var = NULL, |
||
| 222 | -1x | +|||
| 101 | +
- environment(formula) <- environment()+ ex_var = "AVAL", |
|||
| 223 | -1x | +|||
| 102 | +
- suppressWarnings({
+ id = "USUBJID", |
|||
| 224 | +103 |
- # We expect some warnings due to coxph which fails strict programming.+ add_total_level = FALSE, |
||
| 225 | -1x | +|||
| 104 | +
- mod <- survival::coxph(formula, data = data, ...)+ custom_label = NULL, |
|||
| 226 | -1x | +|||
| 105 | +
- msum <- summary(mod, conf.int = conf_level)+ labelstr = "", |
|||
| 227 | +106 |
- })+ .N_col, # nolint |
||
| 228 | +107 |
-
+ .stats, |
||
| 229 | -1x | +|||
| 108 | +
- aov <- try_car_anova(+ .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
|
|||
| 230 | -1x | +109 | +32x |
- mod,+ checkmate::assert_flag(add_total_level) |
| 231 | -1x | +|||
| 110 | +
- test.statistic = switch(pval_method,+ |
|||
| 232 | -1x | +111 | +32x |
- "wald" = "Wald",+ if (!is.null(var)) {
|
| 233 | -1x | +112 | +21x |
- "likelihood" = "LR"+ assert_df_with_variables(df, list(var = var)) |
| 234 | -+ | |||
| 113 | +21x |
- )+ df[[var]] <- as.factor(df[[var]]) |
||
| 235 | +114 |
- )+ } |
||
| 236 | +115 | |||
| 237 | -1x | +116 | +32x |
- warn_attr <- aov$warn_text+ y <- list() |
| 238 | -! | +|||
| 117 | +32x |
- if (!is.null(aov$warn_text)) message(warn_attr)+ if (is.null(var)) {
|
||
| 239 | -+ | |||
| 118 | +11x |
-
+ y[[.stats]] <- list(Total = s_count_patients_sum_exposure( |
||
| 240 | -1x | +119 | +11x |
- aov <- aov$aov+ df = df, |
| 241 | -1x | +120 | +11x |
- y <- list(mod = mod, msum = msum, aov = aov)+ ex_var = ex_var, |
| 242 | -1x | +121 | +11x |
- attr(y, "message") <- warn_attr+ id = id, |
| 243 | -+ | |||
| 122 | +11x |
-
+ labelstr = labelstr, |
||
| 244 | -1x | +123 | +11x |
- return(y)+ .N_col = .N_col, |
| 245 | -+ | |||
| 124 | +11x |
- }+ .stats = .stats, |
||
| 246 | -+ | |||
| 125 | +11x |
-
+ custom_label = custom_label |
||
| 247 | -+ | |||
| 126 | +11x |
- # argument_checks+ )[[.stats]]) |
||
| 248 | +127 |
- check_formula <- function(formula) {
+ } else {
|
||
| 249 | -1x | +128 | +21x |
- if (!(inherits(formula, "formula"))) {
+ for (lvl in levels(df[[var]])) {
|
| 250 | -1x | +129 | +42x |
- stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
+ y[[.stats]][[lvl]] <- s_count_patients_sum_exposure( |
| 251 | -+ | |||
| 130 | +42x |
- }+ df = subset(df, get(var) == lvl), |
||
| 252 | -+ | |||
| 131 | +42x |
-
+ ex_var = ex_var, |
||
| 253 | -! | +|||
| 132 | +42x |
- invisible()+ id = id, |
||
| 254 | -+ | |||
| 133 | +42x |
- }+ labelstr = labelstr, |
||
| 255 | -+ | |||
| 134 | +42x |
-
+ .N_col = .N_col, |
||
| 256 | -+ | |||
| 135 | +42x |
- check_covariate_formulas <- function(covariates) {
+ .stats = .stats, |
||
| 257 | -1x | +136 | +42x |
- if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
+ custom_label = lvl |
| 258 | -1x | +137 | +42x |
- stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
+ )[[.stats]] |
| 259 | +138 |
- }+ } |
||
| 260 | -+ | |||
| 139 | +21x |
-
+ if (add_total_level) {
|
||
| 261 | -! | +|||
| 140 | +2x |
- invisible()+ y[[.stats]][["Total"]] <- s_count_patients_sum_exposure( |
||
| 262 | -+ | |||
| 141 | +2x |
- }+ df = df, |
||
| 263 | -+ | |||
| 142 | +2x |
-
+ ex_var = ex_var, |
||
| 264 | -+ | |||
| 143 | +2x |
- name_covariate_names <- function(covariates) {
+ id = id, |
||
| 265 | -1x | +144 | +2x |
- miss_names <- names(covariates) == ""+ labelstr = labelstr, |
| 266 | -1x | +145 | +2x |
- no_names <- is.null(names(covariates))+ .N_col = .N_col, |
| 267 | -! | +|||
| 146 | +2x |
- if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")+ .stats = .stats, |
||
| 268 | -! | +|||
| 147 | +2x |
- if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ custom_label = custom_label |
||
| 269 | -1x | +148 | +2x |
- return(covariates)+ )[[.stats]] |
| 270 | +149 |
- }+ } |
||
| 271 | +150 |
-
+ } |
||
| 272 | +151 |
- check_increments <- function(increments, covariates) {
+
|
||
| 273 | -1x | +152 | +32x |
- if (!is.null(increments)) {
+ in_rows(.list = y[[.stats]], .formats = .formats[[.stats]]) |
| 274 | -1x | -
- covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ | ||
| 153 | ++ |
+ } |
||
| 275 | -1x | +|||
| 154 | +
- lapply(+ |
|||
| 276 | -1x | +|||
| 155 | +
- X = names(increments), FUN = function(x) {
+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
|||
| 277 | -3x | +|||
| 156 | +
- if (!x %in% covariates) {
+ #' function arguments and additional format arguments. This function is a wrapper for |
|||
| 278 | -1x | +|||
| 157 | +
- warning(+ #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()]. |
|||
| 279 | -1x | +|||
| 158 | +
- paste(+ #' |
|||
| 280 | -1x | +|||
| 159 | +
- "Check `increments`, the `increment` for ", x,+ #' @return |
|||
| 281 | -1x | +|||
| 160 | +
- "doesn't match any names in investigated covariate(s)."+ #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
|||
| 282 | +161 |
- )+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 283 | +162 |
- )+ #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
||
| 284 | +163 |
- }+ #' columns, to the table layout. |
||
| 285 | +164 |
- }+ #' |
||
| 286 | +165 |
- )+ #' @examples |
||
| 287 | +166 |
- }+ #' lyt5 <- basic_table() %>% |
||
| 288 | +167 |
-
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) |
||
| 289 | -1x | +|||
| 168 | +
- invisible()+ #' |
|||
| 290 | +169 |
- }+ #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl) |
||
| 291 | +170 |
-
+ #' result5 |
||
| 292 | +171 |
- #' Multivariate Cox model - summarized results+ #' |
||
| 293 | +172 | ++ |
+ #' lyt6 <- basic_table() %>%+ |
+ |
| 173 | ++ |
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")+ |
+ ||
| 174 |
#' |
|||
| 294 | +175 |
- #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or+ #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl) |
||
| 295 | +176 |
- #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually+ #' result6 |
||
| 296 | +177 |
- #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the+ #' |
||
| 297 | +178 |
- #' covariates included in the model.+ #' @export |
||
| 298 | +179 |
- #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the+ #' @order 3 |
||
| 299 | +180 |
- #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,+ summarize_patients_exposure_in_cols <- function(lyt, # nolint |
||
| 300 | +181 |
- #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,+ var, |
||
| 301 | +182 |
- #' `NEST's bookdown`)+ ex_var = "AVAL", |
||
| 302 | +183 |
- #'+ id = "USUBJID", |
||
| 303 | +184 |
- #' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model+ add_total_level = FALSE, |
||
| 304 | +185 |
- #' including covariates.+ custom_label = NULL, |
||
| 305 | +186 |
- #' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates.+ col_split = TRUE, |
||
| 306 | +187 |
- #' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95.+ na_str = default_na_str(), |
||
| 307 | +188 |
- #' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of+ ..., |
||
| 308 | +189 |
- #' `"wald"` (default) or `"likelihood"`.+ .stats = c("n_patients", "sum_exposure"),
|
||
| 309 | +190 |
- #' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
||
| 310 | +191 |
- #' method for tie handling, one of `exact` (default), `efron`, `breslow`.+ .indent_mods = NULL) {
+ |
+ ||
| 192 | +3x | +
+ extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...) |
||
| 311 | +193 | ++ | + + | +|
| 194 | +3x | +
+ if (col_split) {
+ |
+ ||
| 195 | +3x | +
+ lyt <- split_cols_by_multivar(+ |
+ ||
| 196 | +3x | +
+ lyt = lyt,+ |
+ ||
| 197 | +3x | +
+ vars = rep(var, length(.stats)),+ |
+ ||
| 198 | +3x | +
+ varlabels = .labels[.stats],+ |
+ ||
| 199 | +3x | +
+ extra_args = list(.stats = .stats)+ |
+ ||
| 200 | ++ |
+ )+ |
+ ||
| 201 | ++ |
+ }+ |
+ ||
| 202 | +3x | +
+ summarize_row_groups(+ |
+ ||
| 203 | +3x | +
+ lyt = lyt,+ |
+ ||
| 204 | +3x | +
+ var = var,+ |
+ ||
| 205 | +3x | +
+ cfun = a_count_patients_sum_exposure,+ |
+ ||
| 206 | +3x | +
+ na_str = na_str,+ |
+ ||
| 207 | +3x | +
+ extra_args = extra_args+ |
+ ||
| 208 | ++ |
+ )+ |
+ ||
| 209 | ++ |
+ }+ |
+ ||
| 210 | ++ | + + | +||
| 211 | ++ |
+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ |
+ ||
| 212 | ++ |
+ #' function arguments and additional format arguments. This function is a wrapper for+ |
+ ||
| 213 | ++ |
+ #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].+ |
+ ||
| 214 |
#' |
|||
| 312 | +215 |
- #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`.+ #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required |
||
| 313 | +216 | ++ |
+ #' column split has been done already earlier in the layout pipe.+ |
+ |
| 217 |
#' |
|||
| 314 | +218 |
- #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms+ #' @return |
||
| 315 | +219 |
- #' but is out of scope as defined by the Global Data Standards Repository+ #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
||
| 316 | +220 |
- #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 317 | +221 |
- #'+ #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
||
| 318 | +222 |
- #' @seealso [estimate_coef()].+ #' columns, to the table layout. |
||
| 319 | +223 |
#' |
||
| 320 | +224 |
- #' @examples+ #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows, |
||
| 321 | +225 |
- #' library(dplyr)+ #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple |
||
| 322 | +226 | ++ |
+ #' pages when pagination is used.+ |
+ |
| 227 |
#' |
|||
| 323 | +228 |
- #' adtte <- tern_ex_adtte+ #' @examples |
||
| 324 | +229 |
- #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered+ #' set.seed(1) |
||
| 325 | +230 |
- #' adtte_f <- filter(+ #' df <- data.frame( |
||
| 326 | +231 |
- #' adtte_f,+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
||
| 327 | +232 |
- #' PARAMCD == "OS" &+ #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
|
||
| 328 | +233 |
- #' SEX %in% c("F", "M") &
+ #' SEX = c(rep("Female", 6), rep("Male", 6)),
|
||
| 329 | +234 |
- #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
+ #' AVAL = as.numeric(sample(seq(1, 20), 12)), |
||
| 330 | +235 | ++ |
+ #' stringsAsFactors = TRUE+ |
+ |
| 236 |
#' ) |
|||
| 331 | +237 |
- #' adtte_f$SEX <- droplevels(adtte_f$SEX)+ #' adsl <- data.frame( |
||
| 332 | +238 |
- #' adtte_f$RACE <- droplevels(adtte_f$RACE)+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
||
| 333 | +239 | ++ |
+ #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
+ |
+ |
| 240 | ++ |
+ #' SEX = c(rep("Female", 2), rep("Male", 2)),
+ |
+ ||
| 241 | ++ |
+ #' stringsAsFactors = TRUE+ |
+ ||
| 242 | ++ |
+ #' )+ |
+ ||
| 243 |
#' |
|||
| 334 | +244 |
- #' @keywords internal+ #' lyt <- basic_table() %>% |
||
| 335 | +245 |
- s_cox_multivariate <- function(formula, data,+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
||
| 336 | +246 |
- conf_level = 0.95,+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>% |
||
| 337 | +247 |
- pval_method = c("wald", "likelihood"),
+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE) |
||
| 338 | +248 |
- ...) {
+ #' result <- build_table(lyt, df = df, alt_counts_df = adsl) |
||
| 339 | -1x | +|||
| 249 | +
- tf <- stats::terms(formula, specials = c("strata"))
+ #' result |
|||
| 340 | -1x | +|||
| 250 | +
- covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]+ #' |
|||
| 341 | -1x | +|||
| 251 | +
- lapply(+ #' lyt2 <- basic_table() %>% |
|||
| 342 | -1x | +|||
| 252 | +
- X = covariates,+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
|||
| 343 | -1x | +|||
| 253 | +
- FUN = function(x) {
+ #' summarize_patients_exposure_in_cols( |
|||
| 344 | -3x | +|||
| 254 | +
- if (is.character(data[[x]])) {
+ #' var = "AVAL", col_split = TRUE, |
|||
| 345 | -1x | +|||
| 255 | +
- data[[x]] <<- as.factor(data[[x]])+ #' .stats = "n_patients", custom_label = "some custom label" |
|||
| 346 | +256 |
- }+ #' ) %>% |
||
| 347 | -3x | +|||
| 257 | +
- invisible()+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL") |
|||
| 348 | +258 |
- }+ #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl) |
||
| 349 | +259 |
- )+ #' result2 |
||
| 350 | -1x | +|||
| 260 | +
- pval_method <- match.arg(pval_method)+ #' |
|||
| 351 | +261 |
-
+ #' lyt3 <- basic_table() %>% |
||
| 352 | +262 |
- # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL") |
||
| 353 | -1x | +|||
| 263 | +
- y <- fit_n_aov(+ #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl) |
|||
| 354 | -1x | +|||
| 264 | +
- formula = formula,+ #' result3 |
|||
| 355 | -1x | +|||
| 265 | +
- data = data,+ #' |
|||
| 356 | -1x | +|||
| 266 | +
- conf_level = conf_level,+ #' # Adding total levels and custom label |
|||
| 357 | -1x | +|||
| 267 | +
- pval_method = pval_method,+ #' lyt4 <- basic_table( |
|||
| 358 | +268 |
- ...+ #' show_colcounts = TRUE |
||
| 359 | +269 |
- )+ #' ) %>% |
||
| 360 | -1x | +|||
| 270 | +
- mod <- y$mod+ #' analyze_patients_exposure_in_cols( |
|||
| 361 | -1x | +|||
| 271 | +
- aov <- y$aov+ #' var = "ARMCD", |
|||
| 362 | -1x | +|||
| 272 | +
- msum <- y$msum+ #' col_split = TRUE, |
|||
| 363 | -1x | +|||
| 273 | +
- list2env(as.list(y), environment())+ #' add_total_level = TRUE, |
|||
| 364 | +274 |
-
+ #' custom_label = "TOTAL" |
||
| 365 | -1x | +|||
| 275 | +
- all_term_labs <- attr(mod$terms, "term.labels")+ #' ) %>% |
|||
| 366 | -1x | +|||
| 276 | +
- term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]+ #' append_topleft(c("", "Sex"))
|
|||
| 367 | -1x | +|||
| 277 | +
- names(term_labs) <- term_labs+ #' |
|||
| 368 | +278 |
-
+ #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl) |
||
| 369 | -1x | +|||
| 279 | +
- coef_inter <- NULL+ #' result4 |
|||
| 370 | -1x | +|||
| 280 | +
- if (any(attr(mod$terms, "order") > 1)) {
+ #' |
|||
| 371 | -1x | +|||
| 281 | +
- for_inter <- all_term_labs[attr(mod$terms, "order") > 1]+ #' @export |
|||
| 372 | -1x | +|||
| 282 | +
- names(for_inter) <- for_inter+ #' @order 2 |
|||
| 373 | -1x | +|||
| 283 | +
- mmat <- stats::model.matrix(mod)[1, ]+ analyze_patients_exposure_in_cols <- function(lyt, # nolint |
|||
| 374 | -1x | +|||
| 284 | +
- mmat[!mmat == 0] <- 0+ var = NULL, |
|||
| 375 | -1x | +|||
| 285 | +
- mcoef <- stats::coef(mod)+ ex_var = "AVAL", |
|||
| 376 | -1x | +|||
| 286 | +
- mvcov <- stats::vcov(mod)+ id = "USUBJID", |
|||
| 377 | +287 |
-
+ add_total_level = FALSE, |
||
| 378 | -1x | +|||
| 288 | +
- estimate_coef_local <- function(variable, given) {
+ custom_label = NULL, |
|||
| 379 | -6x | +|||
| 289 | +
- estimate_coef(+ col_split = TRUE, |
|||
| 380 | -6x | +|||
| 290 | +
- variable, given,+ na_str = default_na_str(), |
|||
| 381 | -6x | +|||
| 291 | +
- coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,+ .stats = c("n_patients", "sum_exposure"),
|
|||
| 382 | -6x | +|||
| 292 | +
- lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
|||
| 383 | +293 |
- )+ .indent_mods = 0L, |
||
| 384 | +294 |
- }+ ...) {
+ |
+ ||
| 295 | +6x | +
+ extra_args <- list(+ |
+ ||
| 296 | +6x | +
+ var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ... |
||
| 385 | +297 | ++ |
+ )+ |
+ |
| 298 | ||||
| 386 | -1x | +299 | +6x |
- coef_inter <- lapply(+ if (col_split) {
|
| 387 | -1x | +300 | +4x |
- for_inter, function(x) {
+ lyt <- split_cols_by_multivar( |
| 388 | -3x | +301 | +4x |
- y <- attr(mod$terms, "factors")[, x]+ lyt = lyt, |
| 389 | -3x | +302 | +4x |
- y <- names(y[y > 0])+ vars = rep(ex_var, length(.stats)), |
| 390 | -3x | +303 | +4x |
- Map(estimate_coef_local, variable = y, given = rev(y))+ varlabels = .labels[.stats], |
| 391 | -+ | |||
| 304 | +4x |
- }+ extra_args = list(.stats = .stats) |
||
| 392 | +305 |
) |
||
| 393 | +306 |
} |
||
| 307 | +6x | +
+ lyt <- lyt %>% analyze_colvars(+ |
+ ||
| 308 | +6x | +
+ afun = a_count_patients_sum_exposure,+ |
+ ||
| 309 | +6x | +
+ indent_mod = .indent_mods,+ |
+ ||
| 310 | +6x | +
+ na_str = na_str,+ |
+ ||
| 311 | +6x | +
+ extra_args = extra_args+ |
+ ||
| 394 | +312 |
-
+ ) |
||
| 395 | -1x | +313 | +6x |
- list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)+ lyt |
| 396 | +314 |
}@@ -144414,14 +142724,14 @@ tern coverage - 95.65% |
| 1 |
- #' Count patients with marked laboratory abnormalities+ #' Difference test for two proportions |
||
| 5 |
- #' The analyze function [count_abnormal_by_marked()] creates a layout element to count patients with marked laboratory+ #' The analyze function [test_proportion_diff()] creates a layout element to test the difference between two |
||
| 6 |
- #' abnormalities for each direction of abnormality, categorized by parameter value.+ #' proportions. The primary analysis variable, `vars`, indicates whether a response has occurred for each record. See |
||
| 7 |
- #'+ #' the `method` parameter for options of methods to use to calculate the p-value. Additionally, a stratification |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates whether a single, replicated,+ #' variable can be supplied via the `strata` element of the `variables` argument. |
||
| 9 |
- #' or last marked laboratory abnormality was observed. Levels of `var` to include for each marked lab+ #' |
||
| 10 |
- #' abnormality (`single` and `last_replicated`) can be supplied via the `category` parameter. Additional+ #' @inheritParams argument_convention |
||
| 11 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults+ #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used |
||
| 12 |
- #' to `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a+ #' to calculate the p-value. |
||
| 13 |
- #' variable to indicate parameter values, and `direction` (defaults to `abn_dir`), a variable to indicate+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 14 |
- #' abnormality directions.+ #' |
||
| 15 |
- #'+ #' Options are: ``r shQuote(get_stats("test_proportion_diff"))``
|
||
| 16 |
- #' For each combination of `param` and `direction` levels, marked lab abnormality counts are calculated+ #' |
||
| 17 |
- #' as follows:+ #' @seealso [h_prop_diff_test] |
||
| 18 |
- #' * `Single, not last` & `Last or replicated`: The number of patients with `Single, not last`+ #' |
||
| 19 |
- #' and `Last or replicated` values, respectively.+ #' @name prop_diff_test |
||
| 20 |
- #' * `Any`: The number of patients with either single or replicated marked abnormalities.+ #' @order 1 |
||
| 21 |
- #'+ NULL |
||
| 22 |
- #' Fractions are calculated by dividing the above counts by the number of patients with at least one+ |
||
| 23 |
- #' valid measurement recorded during the analysis.+ #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions. |
||
| 25 |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two+ #' @return |
||
| 26 |
- #' row splits, one on variable `param` and one on variable `direction`.+ #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label` |
||
| 27 |
- #'+ #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same. |
||
| 28 |
- #' @inheritParams argument_convention+ #' |
||
| 29 |
- #' @param category (`list`)\cr a list with different marked category names for single+ #' @keywords internal |
||
| 30 |
- #' and last or replicated.+ s_test_proportion_diff <- function(df, |
||
| 31 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ .var, |
||
| 32 |
- #'+ .ref_group, |
||
| 33 |
- #' Options are: ``r shQuote(get_stats("abnormal_by_marked"))``
+ .in_ref_col, |
||
| 34 |
- #'+ variables = list(strata = NULL), |
||
| 35 |
- #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has+ method = c("chisq", "schouten", "fisher", "cmh")) {
|
||
| 36 | -+ | 45x |
- #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the+ method <- match.arg(method) |
| 37 | -+ | 45x |
- #' patient will be counted only under the `Last or replicated` category.+ y <- list(pval = "") |
| 38 |
- #'+ |
||
| 39 | -+ | 45x |
- #' @name abnormal_by_marked+ if (!.in_ref_col) {
|
| 40 | -+ | 45x |
- #' @order 1+ assert_df_with_variables(df, list(rsp = .var)) |
| 41 | -+ | 45x |
- NULL+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
| 42 | -+ | 45x |
-
+ rsp <- factor( |
| 43 | -+ | 45x |
- #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities.+ c(.ref_group[[.var]], df[[.var]]), |
| 44 | -+ | 45x |
- #'+ levels = c("TRUE", "FALSE")
|
| 45 |
- #' @return+ ) |
||
| 46 | -+ | 45x |
- #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`,+ grp <- factor( |
| 47 | -+ | 45x |
- #' `Last or replicated`, and `Any` results.+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
| 48 | -+ | 45x |
- #'+ levels = c("ref", "Not-ref")
|
| 49 |
- #' @keywords internal+ ) |
||
| 50 |
- s_count_abnormal_by_marked <- function(df,+ |
||
| 51 | -+ | 45x |
- .var = "AVALCAT1",+ if (!is.null(variables$strata) || method == "cmh") {
|
| 52 | -+ | 12x |
- .spl_context,+ strata <- variables$strata |
| 53 | -+ | 12x |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ checkmate::assert_false(is.null(strata)) |
| 54 | -+ | 12x |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
+ strata_vars <- stats::setNames(as.list(strata), strata) |
| 55 | -3x | +12x |
- checkmate::assert_string(.var)+ assert_df_with_variables(df, strata_vars) |
| 56 | -3x | +12x |
- checkmate::assert_list(variables)+ assert_df_with_variables(.ref_group, strata_vars) |
| 57 | -3x | +12x |
- checkmate::assert_list(category)+ strata <- c(interaction(.ref_group[strata]), interaction(df[strata])) |
| 58 | -3x | +
- checkmate::assert_subset(names(category), c("single", "last_replicated"))
+ } |
|
| 59 | -3x | +
- checkmate::assert_subset(names(variables), c("id", "param", "direction"))
+
|
|
| 60 | -3x | +45x |
- checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)+ tbl <- switch(method, |
| 61 | -+ | 45x |
-
+ cmh = table(grp, rsp, strata), |
| 62 | -2x | +45x |
- assert_df_with_variables(df, c(aval = .var, variables))+ table(grp, rsp) |
| 63 | -2x | +
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ ) |
|
| 64 | -2x | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+
|
|
| 65 | -+ | 45x |
-
+ y$pval <- switch(method, |
| 66 | -+ | 45x |
-
+ chisq = prop_chisq(tbl), |
| 67 | -2x | +45x |
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ cmh = prop_cmh(tbl), |
| 68 | -+ | 45x |
- # Patients in the denominator have at least one post-baseline visit.+ fisher = prop_fisher(tbl), |
| 69 | -2x | +45x |
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ schouten = prop_schouten(tbl) |
| 70 | -2x | +
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ ) |
|
| 71 |
- # Some subjects may have a record for high and low directions but+ } |
||
| 72 |
- # should be counted only once.+ |
||
| 73 | -2x | +45x |
- denom <- length(unique(subj_cur_col))+ y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method)) |
| 74 | -+ | 45x |
-
+ y |
| 75 | -2x | +
- if (denom != 0) {
+ } |
|
| 76 | -2x | +
- subjects_last_replicated <- unique(+ |
|
| 77 | -2x | +
- df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]+ #' Description of the difference test between two proportions |
|
| 78 |
- )+ #' |
||
| 79 | -2x | +
- subjects_single <- unique(+ #' @description `r lifecycle::badge("stable")`
|
|
| 80 | -2x | +
- df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]+ #' |
|
| 81 |
- )+ #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`. |
||
| 82 |
- # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.+ #' |
||
| 83 | -2x | +
- subjects_single <- setdiff(subjects_single, subjects_last_replicated)+ #' @inheritParams s_test_proportion_diff |
|
| 84 | -2x | +
- n_single <- length(subjects_single)+ #' |
|
| 85 | -2x | +
- n_last_replicated <- length(subjects_last_replicated)+ #' @return A `string` describing the test from which the p-value is derived. |
|
| 86 | -2x | +
- n_any <- n_single + n_last_replicated+ #' |
|
| 87 | -2x | +
- result <- list(count_fraction = list(+ #' @export |
|
| 88 | -2x | +
- "Single, not last" = c(n_single, n_single / denom),+ d_test_proportion_diff <- function(method) {
|
|
| 89 | -2x | +59x |
- "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),+ checkmate::assert_string(method) |
| 90 | -2x | +59x |
- "Any Abnormality" = c(n_any, n_any / denom)+ meth_part <- switch(method, |
| 91 | -+ | 59x |
- ))+ "schouten" = "Chi-Squared Test with Schouten Correction", |
| 92 | -+ | 59x |
- } else {
+ "chisq" = "Chi-Squared Test", |
| 93 | -! | +59x |
- result <- list(count_fraction = list(+ "cmh" = "Cochran-Mantel-Haenszel Test", |
| 94 | -! | +59x |
- "Single, not last" = c(0, 0),+ "fisher" = "Fisher's Exact Test", |
| 95 | -! | +59x |
- "Last or replicated" = c(0, 0),+ stop(paste(method, "does not have a description")) |
| 96 | -! | +
- "Any Abnormality" = c(0, 0)+ ) |
|
| 97 | -+ | 59x |
- ))+ paste0("p-value (", meth_part, ")")
|
| 98 |
- }+ } |
||
| 100 | -2x | +
- result+ #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`. |
|
| 101 |
- }+ #' |
||
| 102 |
-
+ #' @return |
||
| 103 |
- #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun`+ #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 104 |
- #' in `count_abnormal_by_marked()`.+ #' |
||
| 105 |
- #'+ #' @keywords internal |
||
| 106 |
- #' @return+ a_test_proportion_diff <- make_afun( |
||
| 107 |
- #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()].+ s_test_proportion_diff, |
||
| 108 |
- #'+ .formats = c(pval = "x.xxxx | (<0.0001)"), |
||
| 109 |
- #' @keywords internal+ .indent_mods = c(pval = 1L) |
||
| 110 |
- a_count_abnormal_by_marked <- make_afun(+ ) |
||
| 111 |
- s_count_abnormal_by_marked,+ |
||
| 112 |
- .formats = c(count_fraction = format_count_fraction)+ #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments |
||
| 113 |
- )+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 114 |
-
+ #' |
||
| 115 |
- #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments+ #' @return |
||
| 116 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
||
| 117 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 118 |
- #' @return+ #' the statistics from `s_test_proportion_diff()` to the table layout. |
||
| 119 |
- #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 120 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @examples |
||
| 121 |
- #' the statistics from `s_count_abnormal_by_marked()` to the table layout.+ #' dta <- data.frame( |
||
| 122 |
- #'+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 123 |
- #' @examples+ #' grp = factor(rep(c("A", "B"), each = 50)),
|
||
| 124 |
- #' library(dplyr)+ #' strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
|
||
| 125 |
- #'+ #' ) |
||
| 126 |
- #' df <- data.frame(+ #' |
||
| 127 |
- #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),+ #' # With `rtables` pipelines. |
||
| 128 |
- #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
+ #' l <- basic_table() %>% |
||
| 129 |
- #' ANRIND = factor(c(+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 130 |
- #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",+ #' test_proportion_diff( |
||
| 131 |
- #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",+ #' vars = "rsp", |
||
| 132 |
- #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"+ #' method = "cmh", variables = list(strata = "strata") |
||
| 133 |
- #' )),+ #' ) |
||
| 134 |
- #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
+ #' |
||
| 135 |
- #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
+ #' build_table(l, df = dta) |
||
| 136 |
- #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
+ #' |
||
| 137 |
- #' stringsAsFactors = FALSE+ #' @export |
||
| 138 |
- #' )+ #' @order 2 |
||
| 139 |
- #'+ test_proportion_diff <- function(lyt, |
||
| 140 |
- #' df <- df %>%+ vars, |
||
| 141 |
- #' mutate(abn_dir = factor(+ variables = list(strata = NULL), |
||
| 142 |
- #' case_when(+ method = c("chisq", "schouten", "fisher", "cmh"),
|
||
| 143 |
- #' ANRIND == "LOW LOW" ~ "Low",+ na_str = default_na_str(), |
||
| 144 |
- #' ANRIND == "HIGH HIGH" ~ "High",+ nested = TRUE, |
||
| 145 |
- #' TRUE ~ ""+ ..., |
||
| 146 |
- #' ),+ var_labels = vars, |
||
| 147 |
- #' levels = c("Low", "High")
+ show_labels = "hidden", |
||
| 148 |
- #' ))+ table_names = vars, |
||
| 149 |
- #'+ .stats = NULL, |
||
| 150 |
- #' # Select only post-baseline records.+ .formats = NULL, |
||
| 151 |
- #' df <- df %>% filter(ONTRTFL == "Y")+ .labels = NULL, |
||
| 152 |
- #' df_crp <- df %>%+ .indent_mods = NULL) {
|
||
| 153 | -+ | 6x |
- #' filter(PARAMCD == "CRP") %>%+ extra_args <- list(variables = variables, method = method, ...) |
| 154 |
- #' droplevels()+ |
||
| 155 | -+ | 6x |
- #' full_parent_df <- list(df_crp, "not_needed")+ afun <- make_afun( |
| 156 | -+ | 6x |
- #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")+ a_test_proportion_diff, |
| 157 | -+ | 6x |
- #' spl_context <- data.frame(+ .stats = .stats, |
| 158 | -+ | 6x |
- #' split = c("PARAMCD", "GRADE_DIR"),
+ .formats = .formats, |
| 159 | -+ | 6x |
- #' full_parent_df = I(full_parent_df),+ .labels = .labels, |
| 160 | -+ | 6x |
- #' cur_col_subset = I(cur_col_subset)+ .indent_mods = .indent_mods |
| 161 |
- #' )+ ) |
||
| 162 | -+ | 6x |
- #'+ analyze( |
| 163 | -+ | 6x |
- #' map <- unique(+ lyt, |
| 164 | -+ | 6x |
- #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
+ vars, |
| 165 | -+ | 6x |
- #' ) %>%+ afun = afun, |
| 166 | -+ | 6x |
- #' lapply(as.character) %>%+ var_labels = var_labels, |
| 167 | -+ | 6x |
- #' as.data.frame() %>%+ na_str = na_str, |
| 168 | -+ | 6x |
- #' arrange(PARAMCD, abn_dir)+ nested = nested, |
| 169 | -+ | 6x |
- #'+ extra_args = extra_args, |
| 170 | -+ | 6x |
- #' basic_table() %>%+ show_labels = show_labels, |
| 171 | -+ | 6x |
- #' split_cols_by("ARMCD") %>%
+ table_names = table_names |
| 172 |
- #' split_rows_by("PARAMCD") %>%
+ ) |
||
| 173 |
- #' summarize_num_patients(+ } |
||
| 174 |
- #' var = "USUBJID",+ |
||
| 175 |
- #' .stats = "unique_count"+ #' Helper functions to test proportion differences |
||
| 176 |
- #' ) %>%+ #' |
||
| 177 |
- #' split_rows_by(+ #' Helper functions to implement various tests on the difference between two proportions. |
||
| 178 |
- #' "abn_dir",+ #' |
||
| 179 |
- #' split_fun = trim_levels_to_map(map)+ #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns. |
||
| 180 |
- #' ) %>%+ #' |
||
| 181 |
- #' count_abnormal_by_marked(+ #' @return A p-value. |
||
| 182 |
- #' var = "AVALCAT1",+ #' |
||
| 183 |
- #' variables = list(+ #' @seealso [prop_diff_test()] for implementation of these helper functions. |
||
| 184 |
- #' id = "USUBJID",+ #' |
||
| 185 |
- #' param = "PARAMCD",+ #' @name h_prop_diff_test |
||
| 186 |
- #' direction = "abn_dir"+ NULL |
||
| 187 |
- #' )+ |
||
| 188 |
- #' ) %>%+ #' @describeIn h_prop_diff_test Performs Chi-Squared test. Internally calls [stats::prop.test()]. |
||
| 189 |
- #' build_table(df = df)+ #' |
||
| 190 |
- #'+ #' @keywords internal |
||
| 191 |
- #' basic_table() %>%+ prop_chisq <- function(tbl) {
|
||
| 192 | -+ | 41x |
- #' split_cols_by("ARMCD") %>%
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 193 | -+ | 41x |
- #' split_rows_by("PARAMCD") %>%
+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 194 | -+ | 41x |
- #' summarize_num_patients(+ if (any(colSums(tbl) == 0)) {
|
| 195 | -+ | 2x |
- #' var = "USUBJID",+ return(1) |
| 196 |
- #' .stats = "unique_count"+ } |
||
| 197 | -+ | 39x |
- #' ) %>%+ stats::prop.test(tbl, correct = FALSE)$p.value |
| 198 |
- #' split_rows_by(+ } |
||
| 199 |
- #' "abn_dir",+ |
||
| 200 |
- #' split_fun = trim_levels_in_group("abn_dir")
+ #' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test. Internally calls |
||
| 201 |
- #' ) %>%+ #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded. |
||
| 202 |
- #' count_abnormal_by_marked(+ #' |
||
| 203 |
- #' var = "AVALCAT1",+ #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response |
||
| 204 |
- #' variables = list(+ #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension. |
||
| 205 |
- #' id = "USUBJID",+ #' |
||
| 206 |
- #' param = "PARAMCD",+ #' @keywords internal |
||
| 207 |
- #' direction = "abn_dir"+ prop_cmh <- function(ary) {
|
||
| 208 | -+ | 16x |
- #' )+ checkmate::assert_array(ary) |
| 209 | -+ | 16x |
- #' ) %>%+ checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2) |
| 210 | -+ | 16x |
- #' build_table(df = df)+ checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3) |
| 211 | -+ | 16x |
- #'+ strata_sizes <- apply(ary, MARGIN = 3, sum) |
| 212 | -+ | 16x |
- #' @export+ if (any(strata_sizes < 5)) {
|
| 213 | -+ | 1x |
- #' @order 2+ warning("<5 data points in some strata. CMH test may be incorrect.")
|
| 214 | -+ | 1x |
- count_abnormal_by_marked <- function(lyt,+ ary <- ary[, , strata_sizes > 1] |
| 215 |
- var,+ } |
||
| 216 |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+
|
||
| 217 | -+ | 16x |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"),+ stats::mantelhaen.test(ary, correct = FALSE)$p.value |
| 218 |
- na_str = default_na_str(),+ } |
||
| 219 |
- nested = TRUE,+ |
||
| 220 |
- ...,+ #' @describeIn h_prop_diff_test Performs the Chi-Squared test with Schouten correction. |
||
| 221 |
- .stats = NULL,+ #' |
||
| 222 |
- .formats = NULL,+ #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
|
||
| 223 |
- .labels = NULL,+ #' |
||
| 224 |
- .indent_mods = NULL) {
+ #' @keywords internal |
||
| 225 | -1x | +
- checkmate::assert_string(var)+ prop_schouten <- function(tbl) {
|
|
| 226 | -+ | 100x |
-
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 227 | -1x | +100x |
- extra_args <- list(category = category, variables = variables, ...)+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 228 | -+ | 100x |
-
+ if (any(colSums(tbl) == 0)) {
|
| 229 | 1x |
- afun <- make_afun(+ return(1) |
|
| 230 | -1x | +
- a_count_abnormal_by_marked,+ } |
|
| 231 | -1x | +
- .stats = .stats,+ |
|
| 232 | -1x | +99x |
- .formats = .formats,+ n <- sum(tbl) |
| 233 | -1x | +99x |
- .labels = .labels,+ n1 <- sum(tbl[1, ]) |
| 234 | -1x | +99x |
- .indent_mods = .indent_mods,+ n2 <- sum(tbl[2, ]) |
| 235 | -1x | +
- .ungroup_stats = "count_fraction"+ |
|
| 236 | -+ | 99x |
- )+ ad <- diag(tbl) |
| 237 | -+ | 99x |
-
+ bc <- diag(apply(tbl, 2, rev)) |
| 238 | -1x | +99x |
- lyt <- analyze(+ ac <- tbl[, 1] |
| 239 | -1x | +99x |
- lyt = lyt,+ bd <- tbl[, 2] |
| 240 | -1x | +
- vars = var,+ |
|
| 241 | -1x | +99x |
- afun = afun,+ t_schouten <- (n - 1) * |
| 242 | -1x | +99x |
- na_str = na_str,+ (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 / |
| 243 | -1x | +99x |
- nested = nested,+ (n1 * n2 * sum(ac) * sum(bd)) |
| 244 | -1x | +
- show_labels = "hidden",+ |
|
| 245 | -1x | +99x |
- extra_args = extra_args+ 1 - stats::pchisq(t_schouten, df = 1) |
| 246 |
- )+ } |
||
| 247 | -1x | +
- lyt+ |
|
| 248 | + |
+ #' @describeIn h_prop_diff_test Performs the Fisher's exact test. Internally calls [stats::fisher.test()].+ |
+ |
| 249 | ++ |
+ #'+ |
+ |
| 250 | ++ |
+ #' @keywords internal+ |
+ |
| 251 | ++ |
+ prop_fisher <- function(tbl) {
+ |
+ |
| 252 | +2x | +
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ |
+ |
| 253 | +2x | +
+ tbl <- tbl[, c("TRUE", "FALSE")]
+ |
+ |
| 254 | +2x | +
+ stats::fisher.test(tbl)$p.value+ |
+ |
| 255 | +
} |
@@ -146156,14 +144515,14 @@
| 1 |
- #' Count patients by most extreme post-baseline toxicity grade per direction of abnormality+ #' Re-implemented `range()` default S3 method for numerical objects |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data |
||
| 4 |
- #'+ #' without any warnings. |
||
| 5 |
- #' The analyze function [count_abnormal_by_worst_grade()] creates a layout element to count patients by highest (worst)+ #' |
||
| 6 |
- #' analysis toxicity grade post-baseline for each direction, categorized by parameter value.+ #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed. |
||
| 7 |
- #'+ #' @param na.rm (`flag`)\cr flag indicating if `NA` should be omitted. |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates toxicity grades. Additional+ #' @param finite (`flag`)\cr flag indicating if non-finite elements should be removed. |
||
| 9 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to+ #' |
||
| 10 |
- #' `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a variable+ #' @return A 2-element vector of class `numeric`. |
||
| 11 |
- #' to indicate parameter values, and `grade_dir` (defaults to `GRADE_DIR`), a variable to indicate directions+ #' |
||
| 12 |
- #' (e.g. High or Low) for each toxicity grade supplied in `var`.+ #' @keywords internal |
||
| 13 |
- #'+ range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
|
||
| 14 |
- #' For each combination of `param` and `grade_dir` levels, patient counts by worst+ |
||
| 15 | -+ | 1878x |
- #' grade are calculated as follows:+ checkmate::assert_numeric(x) |
| 16 |
- #' * `1` to `4`: The number of patients with worst grades 1-4, respectively.+ |
||
| 17 | -+ | 1878x |
- #' * `Any`: The number of patients with at least one abnormality (i.e. grade is not 0).+ if (finite) {
|
| 18 | -+ | 24x |
- #'+ x <- x[is.finite(x)] # removes NAs too |
| 19 | -+ | 1854x |
- #' Fractions are calculated by dividing the above counts by the number of patients with at least one+ } else if (na.rm) {
|
| 20 | -+ | 708x |
- #' valid measurement recorded during treatment.+ x <- x[!is.na(x)] |
| 21 |
- #'+ } |
||
| 22 |
- #' Pre-processing is crucial when using this function and can be done automatically using the+ |
||
| 23 | -+ | 1878x |
- #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the+ if (length(x) == 0) {
|
| 24 | -+ | 111x |
- #' necessary pre-processing steps.+ rval <- c(NA, NA) |
| 25 | -+ | 111x |
- #'+ mode(rval) <- typeof(x) |
| 26 |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two row+ } else {
|
||
| 27 | -+ | 1767x |
- #' splits, one on variable `param` and one on variable `grade_dir`.+ rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE)) |
| 28 |
- #'+ } |
||
| 29 |
- #' @inheritParams argument_convention+ |
||
| 30 | -+ | 1878x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ return(rval) |
| 31 |
- #'+ } |
||
| 32 |
- #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade"))``
+
|
||
| 33 |
- #'+ #' Utility function to create label for confidence interval |
||
| 34 |
- #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes ADLB data frames to be used in+ #' |
||
| 35 |
- #' [count_abnormal_by_worst_grade()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 37 |
- #' @name abnormal_by_worst_grade+ #' @inheritParams argument_convention |
||
| 38 |
- #' @order 1+ #' |
||
| 39 |
- NULL+ #' @return A `string`. |
||
| 40 |
-
+ #' |
||
| 41 |
- #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade.+ #' @export |
||
| 42 |
- #'+ f_conf_level <- function(conf_level) {
|
||
| 43 | -+ | 3968x |
- #' @return+ assert_proportion_value(conf_level) |
| 44 | -+ | 3966x |
- #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and+ paste0(conf_level * 100, "% CI") |
| 45 |
- #' "Any" results.+ } |
||
| 46 |
- #'+ |
||
| 47 |
- #' @keywords internal+ #' Utility function to create label for p-value |
||
| 48 |
- s_count_abnormal_by_worst_grade <- function(df, # nolint+ #' |
||
| 49 |
- .var = "GRADE_ANL",+ #' @description `r lifecycle::badge("stable")`
|
||
| 50 |
- .spl_context,+ #' |
||
| 51 |
- variables = list(+ #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis. |
||
| 52 |
- id = "USUBJID",+ #' |
||
| 53 |
- param = "PARAM",+ #' @return A `string`. |
||
| 54 |
- grade_dir = "GRADE_DIR"+ #' |
||
| 55 |
- )) {
+ #' @export |
||
| 56 | -1x | +
- checkmate::assert_string(.var)+ f_pval <- function(test_mean) {
|
|
| 57 | -1x | +1139x |
- assert_valid_factor(df[[.var]])+ checkmate::assert_numeric(test_mean, len = 1) |
| 58 | -1x | +1137x |
- assert_valid_factor(df[[variables$param]])+ paste0("p-value (H0: mean = ", test_mean, ")")
|
| 59 | -1x | +
- assert_valid_factor(df[[variables$grade_dir]])+ } |
|
| 60 | -1x | +
- assert_df_with_variables(df, c(a = .var, variables))+ |
|
| 61 | -1x | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ #' Utility function to return a named list of covariate names |
|
| 62 |
-
+ #' |
||
| 63 |
- # To verify that the `split_rows_by` are performed with correct variables.+ #' @param covariates (`character`)\cr a vector that can contain single variable names (such as |
||
| 64 | -1x | +
- checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
|
| 65 | -1x | +
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ #' |
|
| 66 | -1x | +
- x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ #' @return A named `list` of `character` vector. |
|
| 67 | -1x | +
- result <- split(numeric(0), factor(x_lvls))+ #' |
|
| 68 |
-
+ #' @keywords internal |
||
| 69 | -1x | +
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ get_covariates <- function(covariates) {
|
|
| 70 | -1x | +14x |
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ checkmate::assert_character(covariates) |
| 71 | -+ | 12x |
- # Some subjects may have a record for high and low directions but+ cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*")))) |
| 72 | -+ | 12x |
- # should be counted only once.+ stats::setNames(as.list(cov_vars), cov_vars) |
| 73 | -1x | +
- denom <- length(unique(subj_cur_col))+ } |
|
| 75 | -1x | +
- for (lvl in x_lvls) {
+ #' Replicate entries of a vector if required |
|
| 76 | -5x | +
- if (lvl != "Any") {
+ #' |
|
| 77 | -4x | +
- df_lvl <- df[df[[.var]] == lvl, ]+ #' @description `r lifecycle::badge("stable")`
|
|
| 78 |
- } else {
+ #' |
||
| 79 | -1x | +
- df_lvl <- df[df[[.var]] != 0, ]+ #' Replicate entries of a vector if required. |
|
| 80 |
- }+ #' |
||
| 81 | -5x | +
- num <- length(unique(df_lvl[[variables[["id"]]]]))+ #' @inheritParams argument_convention |
|
| 82 | -5x | +
- fraction <- ifelse(denom == 0, 0, num / denom)+ #' @param n (`integer(1)`)\cr number of entries that are needed. |
|
| 83 | -5x | +
- result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)+ #' |
|
| 84 |
- }+ #' @return `x` if it has the required length already or is `NULL`, |
||
| 85 |
-
+ #' otherwise if it is scalar the replicated version of it with `n` entries. |
||
| 86 | -1x | +
- result <- list(count_fraction = result)+ #' |
|
| 87 | -1x | +
- result+ #' @note This function will fail if `x` is not of length `n` and/or is not a scalar. |
|
| 88 |
- }+ #' |
||
| 89 |
-
+ #' @export |
||
| 90 |
- #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun`+ to_n <- function(x, n) {
|
||
| 91 | -+ | 5x |
- #' in `count_abnormal_by_worst_grade()`.+ if (is.null(x)) {
|
| 92 | -+ | 1x |
- #'+ NULL |
| 93 | -+ | 4x |
- #' @return+ } else if (length(x) == 1) {
|
| 94 | -+ | 1x |
- #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ rep(x, n) |
| 95 | -+ | 3x |
- #'+ } else if (length(x) == n) {
|
| 96 | -+ | 2x |
- #' @keywords internal+ x |
| 97 |
- a_count_abnormal_by_worst_grade <- make_afun( # nolint+ } else {
|
||
| 98 | -+ | 1x |
- s_count_abnormal_by_worst_grade,+ stop("dimension mismatch")
|
| 99 |
- .formats = c(count_fraction = format_count_fraction)+ } |
||
| 100 |
- )+ } |
||
| 102 |
- #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments+ #' Check element dimension |
||
| 103 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 104 |
- #'+ #' Checks if the elements in `...` have the same dimension. |
||
| 105 |
- #' @return+ #' |
||
| 106 |
- #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions,+ #' @param ... (`data.frame` or `vector`)\cr any data frames or vectors. |
||
| 107 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @param omit_null (`flag`)\cr whether `NULL` elements in `...` should be omitted from the check. |
||
| 108 |
- #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout.+ #' |
||
| 109 |
- #'+ #' @return A `logical` value. |
||
| 110 |
- #' @examples+ #' |
||
| 111 |
- #' library(dplyr)+ #' @keywords internal |
||
| 112 |
- #' library(forcats)+ check_same_n <- function(..., omit_null = TRUE) {
|
||
| 113 | -+ | 2x |
- #' adlb <- tern_ex_adlb+ dots <- list(...) |
| 114 |
- #'+ |
||
| 115 | -+ | 2x |
- #' # Data is modified in order to have some parameters with grades only in one direction+ n_list <- Map( |
| 116 | -+ | 2x |
- #' # and simulate the real data.+ function(x, name) {
|
| 117 | -+ | 5x |
- #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
+ if (is.null(x)) {
|
| 118 | -+ | ! |
- #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"+ if (omit_null) {
|
| 119 | -+ | 2x |
- #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""+ NA_integer_ |
| 120 |
- #'+ } else {
|
||
| 121 | -+ | ! |
- #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
+ stop("arg", name, "is not supposed to be NULL")
|
| 122 |
- #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"+ } |
||
| 123 | -+ | 5x |
- #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""+ } else if (is.data.frame(x)) {
|
| 124 | -+ | ! |
- #'+ nrow(x) |
| 125 | -+ | 5x |
- #' # Pre-processing+ } else if (is.atomic(x)) {
|
| 126 | -+ | 5x |
- #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade()+ length(x) |
| 127 |
- #'+ } else {
|
||
| 128 | -+ | ! |
- #' # Map excludes records without abnormal grade since they should not be displayed+ stop("data structure for ", name, "is currently not supported")
|
| 129 |
- #' # in the table.+ } |
||
| 130 |
- #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
+ }, |
||
| 131 | -+ | 2x |
- #' lapply(as.character) %>%+ dots, names(dots) |
| 132 |
- #' as.data.frame() %>%+ ) |
||
| 133 |
- #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)+ |
||
| 134 | -+ | 2x |
- #'+ n <- stats::na.omit(unlist(n_list)) |
| 135 |
- #' basic_table() %>%+ |
||
| 136 | -+ | 2x |
- #' split_cols_by("ARMCD") %>%
+ if (length(unique(n)) > 1) {
|
| 137 | -+ | ! |
- #' split_rows_by("PARAM") %>%
+ sel <- which(n != n[1]) |
| 138 | -+ | ! |
- #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
+ stop("Dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
|
| 139 |
- #' count_abnormal_by_worst_grade(+ } |
||
| 140 |
- #' var = "GRADE_ANL",+ |
||
| 141 | -+ | 2x |
- #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")+ TRUE |
| 142 |
- #' ) %>%+ } |
||
| 143 |
- #' build_table(df = adlb_f)+ |
||
| 144 |
- #'+ #' Utility function to check if a float value is equal to another float value |
||
| 145 |
- #' @export+ #' |
||
| 146 |
- #' @order 2+ #' Uses `.Machine$double.eps` as the tolerance for the comparison. |
||
| 147 |
- count_abnormal_by_worst_grade <- function(lyt,+ #' |
||
| 148 |
- var,+ #' @param x (`numeric(1)`)\cr a float number. |
||
| 149 |
- variables = list(+ #' @param y (`numeric(1)`)\cr a float number. |
||
| 150 |
- id = "USUBJID",+ #' |
||
| 151 |
- param = "PARAM",+ #' @return `TRUE` if identical, otherwise `FALSE`. |
||
| 152 |
- grade_dir = "GRADE_DIR"+ #' |
||
| 153 |
- ),+ #' @keywords internal |
||
| 154 |
- na_str = default_na_str(),+ .is_equal_float <- function(x, y) {
|
||
| 155 | -+ | 2990x |
- nested = TRUE,+ checkmate::assert_number(x) |
| 156 | -+ | 2990x |
- ...,+ checkmate::assert_number(y) |
| 157 |
- .stats = NULL,+ |
||
| 158 |
- .formats = NULL,+ # Define a tolerance |
||
| 159 | -+ | 2990x |
- .labels = NULL,+ tolerance <- .Machine$double.eps |
| 160 |
- .indent_mods = NULL) {
+
|
||
| 161 | -2x | +
- extra_args <- list(variables = variables, ...)+ # Check if x is close enough to y |
|
| 162 | -+ | 2990x |
-
+ abs(x - y) < tolerance |
| 163 | -2x | +
- afun <- make_afun(+ } |
|
| 164 | -2x | +
- a_count_abnormal_by_worst_grade,+ |
|
| 165 | -2x | +
- .stats = .stats,+ #' Make names without dots |
|
| 166 | -2x | +
- .formats = .formats,+ #' |
|
| 167 | -2x | +
- .labels = .labels,+ #' @param nams (`character`)\cr vector of original names. |
|
| 168 | -2x | +
- .indent_mods = .indent_mods,+ #' |
|
| 169 | -2x | +
- .ungroup_stats = "count_fraction"+ #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()]. |
|
| 170 |
- )+ #' |
||
| 171 | -2x | +
- analyze(+ #' @keywords internal |
|
| 172 | -2x | +
- lyt = lyt,+ make_names <- function(nams) {
|
|
| 173 | -2x | +6x |
- vars = var,+ orig <- make.names(nams) |
| 174 | -2x | +6x |
- afun = afun,+ gsub(".", "", x = orig, fixed = TRUE)
|
| 175 | -2x | +
- na_str = na_str,+ } |
|
| 176 | -2x | +
- nested = nested,+ |
|
| 177 | -2x | +
- extra_args = extra_args,+ #' Conversion of months to days |
|
| 178 | -2x | +
- show_labels = "hidden"+ #' |
|
| 179 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 180 |
- }+ #' |
||
| 181 |
-
+ #' Conversion of months to days. This is an approximative calculation because it |
||
| 182 |
- #' Helper function to prepare ADLB for `count_abnormal_by_worst_grade()`+ #' considers each month as having an average of 30.4375 days. |
||
| 184 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param x (`numeric(1)`)\cr time in months. |
||
| 186 |
- #' Helper function to prepare an ADLB data frame to be used as input in+ #' @return A `numeric` vector with the time in days. |
||
| 187 |
- #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied:+ #' |
||
| 188 |
- #'+ #' @examples |
||
| 189 |
- #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits.+ #' x <- c(13.25, 8.15, 1, 2.834) |
||
| 190 |
- #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only+ #' month2day(x) |
||
| 191 |
- #' worst grades (in either direction) are included.+ #' |
||
| 192 |
- #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived+ #' @export |
||
| 193 |
- #' and added to `adlb`:+ month2day <- function(x) {
|
||
| 194 | -+ | 1x |
- #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when+ checkmate::assert_numeric(x) |
| 195 | -+ | 1x |
- #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise.+ x * 30.4375 |
| 196 |
- #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are+ } |
||
| 197 |
- #' replaced by their absolute values.+ |
||
| 198 |
- #' 4. Unused factor levels are dropped from `adlb` via [droplevels()].+ #' Conversion of days to months |
||
| 200 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ #' @param x (`numeric(1)`)\cr time in days. |
||
| 201 |
- #' @param atoxgr (`string`)\cr name of the analysis toxicity grade variable. This must be a `factor`+ #' |
||
| 202 |
- #' variable.+ #' @return A `numeric` vector with the time in months. |
||
| 203 |
- #' @param avisit (`string`)\cr name of the analysis visit variable.+ #' |
||
| 204 |
- #' @param worst_flag_low (`string`)\cr name of the worst low lab grade flag variable. This variable is+ #' @examples |
||
| 205 |
- #' set to `"Y"` when indicating records of worst low lab grades.+ #' x <- c(403, 248, 30, 86) |
||
| 206 |
- #' @param worst_flag_high (`string`)\cr name of the worst high lab grade flag variable. This variable is+ #' day2month(x) |
||
| 207 |
- #' set to `"Y"` when indicating records of worst high lab grades.+ #' |
||
| 208 |
- #'+ #' @export |
||
| 209 |
- #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new+ day2month <- function(x) {
|
||
| 210 | -+ | 19x |
- #' variables: `GRADE_DIR` and `GRADE_ANL`.+ checkmate::assert_numeric(x) |
| 211 | -+ | 19x |
- #'+ x / 30.4375 |
| 212 |
- #' @seealso [abnormal_by_worst_grade]+ } |
||
| 213 |
- #'+ |
||
| 214 |
- #' @examples+ #' Return an empty numeric if all elements are `NA`. |
||
| 215 |
- #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>%+ #' |
||
| 216 |
- #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>%+ #' @param x (`numeric`)\cr vector. |
||
| 217 |
- #' head(10)+ #' |
||
| 218 |
- #'+ #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`. |
||
| 219 |
- #' @export+ #' |
||
| 220 |
- h_adlb_abnormal_by_worst_grade <- function(adlb,+ #' @examples |
||
| 221 |
- atoxgr = "ATOXGR",+ #' x <- c(NA, NA, NA) |
||
| 222 |
- avisit = "AVISIT",+ #' # Internal function - empty_vector_if_na |
||
| 223 |
- worst_flag_low = "WGRLOFL",+ #' @keywords internal |
||
| 224 |
- worst_flag_high = "WGRHIFL") {
+ empty_vector_if_na <- function(x) {
|
||
| 225 | -1x | +1017x |
- adlb %>%+ if (all(is.na(x))) {
|
| 226 | -1x | +310x |
- dplyr::filter(+ numeric() |
| 227 | -1x | +
- !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
+ } else {
|
|
| 228 | -1x | +707x |
- .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y"+ x |
| 229 |
- ) %>%+ } |
||
| 230 | -1x | +
- dplyr::mutate(+ } |
|
| 231 | -1x | +
- GRADE_DIR = factor(+ |
|
| 232 | -1x | +
- dplyr::case_when(+ #' Element-wise combination of two vectors |
|
| 233 | -1x | +
- .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ #' |
|
| 234 | -1x | +
- .data[[atoxgr]] == "0" ~ "ZERO",+ #' @param x (`vector`)\cr first vector to combine. |
|
| 235 | -1x | +
- .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
+ #' @param y (`vector`)\cr second vector to combine. |
|
| 236 |
- ),+ #' |
||
| 237 | -1x | +
- levels = c("LOW", "ZERO", "HIGH")
+ #' @return A `list` where each element combines corresponding elements of `x` and `y`. |
|
| 238 |
- ),+ #' |
||
| 239 | -1x | +
- GRADE_ANL = forcats::fct_relevel(+ #' @examples |
|
| 240 | -1x | +
- forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ #' combine_vectors(1:3, 4:6) |
|
| 241 | -1x | +
- c("0", "1", "2", "3", "4")
+ #' |
|
| 242 |
- )+ #' @export |
||
| 243 |
- ) %>%+ combine_vectors <- function(x, y) {
|
||
| 244 | -1x | +51x |
- droplevels()+ checkmate::assert_vector(x) |
| 245 | -+ | 51x |
- }+ checkmate::assert_vector(y, len = length(x)) |
| 1 | +246 |
- #' Subgroup treatment effect pattern (STEP) fit for binary (response) outcome+ |
||
| 2 | -+ | |||
| 247 | +51x |
- #'+ result <- lapply(as.data.frame(rbind(x, y)), `c`) |
||
| 3 | -+ | |||
| 248 | +51x |
- #' @description `r lifecycle::badge("stable")`
+ names(result) <- NULL |
||
| 4 | -+ | |||
| 249 | +51x |
- #'+ result |
||
| 5 | +250 |
- #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary+ } |
||
| 6 | +251 |
- #' (response) outcome. The treatment arm variable must have exactly 2 levels,+ |
||
| 7 | +252 |
- #' where the first one is taken as reference and the estimated odds ratios are+ #' Extract elements by name |
||
| 8 | +253 |
- #' for the comparison of the second level vs. the first one.+ #' |
||
| 9 | +254 |
- #'+ #' This utility function extracts elements from a vector `x` by `names`. |
||
| 10 | +255 |
- #' The (conditional) logistic regression model which is fit is:+ #' Differences to the standard `[` function are: |
||
| 11 | +256 |
#' |
||
| 12 | +257 |
- #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function). |
||
| 13 | +258 |
- #'+ #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those |
||
| 14 | +259 |
- #' where `degree` is specified by `control_step()`.+ #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s. |
||
| 15 | +260 |
#' |
||
| 16 | +261 |
- #' @inheritParams argument_convention+ #' @param x (named `vector`)\cr where to extract named elements from. |
||
| 17 | +262 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables:+ #' @param names (`character`)\cr vector of names to extract. |
||
| 18 | +263 |
- #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`.+ #' |
||
| 19 | +264 |
- #' @param control (named `list`)\cr combined control list from [control_step()]+ #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`. |
||
| 20 | +265 |
- #' and [control_logistic()].+ #' |
||
| 21 | +266 |
- #'+ #' @keywords internal |
||
| 22 | +267 |
- #' @return A matrix of class `step`. The first part of the columns describe the+ extract_by_name <- function(x, names) {
|
||
| 23 | -+ | |||
| 268 | +3x |
- #' subgroup intervals used for the biomarker variable, including where the+ if (is.null(x)) {
|
||
| 24 | -+ | |||
| 269 | +1x |
- #' center of the intervals are and their bounds. The second part of the+ return(NULL) |
||
| 25 | +270 |
- #' columns contain the estimates for the treatment arm comparison.+ } |
||
| 26 | -+ | |||
| 271 | +2x |
- #'+ checkmate::assert_named(x) |
||
| 27 | -+ | |||
| 272 | +2x |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ checkmate::assert_character(names) |
||
| 28 | -+ | |||
| 273 | +2x |
- #'+ which_extract <- intersect(names(x), names) |
||
| 29 | -+ | |||
| 274 | +2x |
- #' @seealso [control_step()] and [control_logistic()] for the available+ if (length(which_extract) > 0) {
|
||
| 30 | -+ | |||
| 275 | +1x |
- #' customization options.+ x[which_extract] |
||
| 31 | +276 |
- #'+ } else {
|
||
| 32 | -+ | |||
| 277 | +1x |
- #' @examples+ NULL |
||
| 33 | +278 |
- #' # Testing dataset with just two treatment arms.+ } |
||
| 34 | +279 |
- #' library(survival)+ } |
||
| 35 | +280 |
- #' library(dplyr)+ |
||
| 36 | +281 |
- #'+ #' Labels for adverse event baskets |
||
| 37 | +282 |
- #' adrs_f <- tern_ex_adrs %>%+ #' |
||
| 38 | +283 |
- #' filter(+ #' @description `r lifecycle::badge("stable")`
|
||
| 39 | +284 |
- #' PARAMCD == "BESRSPI",+ #' |
||
| 40 | +285 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ #' @param aesi (`character`)\cr vector with standardized MedDRA query name (e.g. `SMQxxNAM`) or customized query |
||
| 41 | +286 |
- #' ) %>%+ #' name (e.g. `CQxxNAM`). |
||
| 42 | +287 |
- #' mutate(+ #' @param scope (`character`)\cr vector with scope of query (e.g. `SMQxxSC`). |
||
| 43 | +288 |
- #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations.+ #' |
||
| 44 | +289 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ #' @return A `string` with the standard label for the AE basket. |
||
| 45 | +290 |
- #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' |
||
| 46 | +291 |
- #' SEX = factor(SEX)+ #' @examples |
||
| 47 | +292 |
- #' )+ #' adae <- tern_ex_adae |
||
| 48 | +293 |
#' |
||
| 49 | +294 |
- #' variables <- list(+ #' # Standardized query label includes scope. |
||
| 50 | +295 |
- #' arm = "ARM",+ #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC) |
||
| 51 | +296 |
- #' biomarker = "BMRKR1",+ #' |
||
| 52 | +297 |
- #' covariates = "AGE",+ #' # Customized query label. |
||
| 53 | +298 |
- #' response = "RSP"+ #' aesi_label(adae$CQ01NAM) |
||
| 54 | +299 |
- #' )+ #' |
||
| 55 | +300 |
- #'+ #' @export |
||
| 56 | +301 |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ aesi_label <- function(aesi, scope = NULL) {
|
||
| 57 | -+ | |||
| 302 | +4x |
- #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those.+ checkmate::assert_character(aesi) |
||
| 58 | -+ | |||
| 303 | +4x |
- #' step_matrix <- fit_rsp_step(+ checkmate::assert_character(scope, null.ok = TRUE) |
||
| 59 | -+ | |||
| 304 | +4x |
- #' variables = variables,+ aesi_label <- obj_label(aesi) |
||
| 60 | -+ | |||
| 305 | +4x |
- #' data = adrs_f,+ aesi <- sas_na(aesi) |
||
| 61 | -+ | |||
| 306 | +4x |
- #' control = c(control_logistic(), control_step(bandwidth = 0.9))+ aesi <- unique(aesi)[!is.na(unique(aesi))] |
||
| 62 | +307 |
- #' )+ |
||
| 63 | -+ | |||
| 308 | +4x |
- #' dim(step_matrix)+ lbl <- if (length(aesi) == 1 && !is.null(scope)) {
|
||
| 64 | -+ | |||
| 309 | +1x |
- #' head(step_matrix)+ scope <- sas_na(scope) |
||
| 65 | -+ | |||
| 310 | +1x |
- #'+ scope <- unique(scope)[!is.na(unique(scope))] |
||
| 66 | -+ | |||
| 311 | +1x |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ checkmate::assert_string(scope) |
||
| 67 | -+ | |||
| 312 | +1x |
- #' # models. Or specify different logistic regression options, including confidence level.+ paste0(aesi, " (", scope, ")")
|
||
| 68 | -+ | |||
| 313 | +4x |
- #' step_matrix2 <- fit_rsp_step(+ } else if (length(aesi) == 1 && is.null(scope)) {
|
||
| 69 | -+ | |||
| 314 | +1x |
- #' variables = variables,+ aesi |
||
| 70 | +315 |
- #' data = adrs_f,+ } else {
+ |
+ ||
| 316 | +2x | +
+ aesi_label |
||
| 71 | +317 |
- #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = NULL, degree = 1))+ } |
||
| 72 | +318 |
- #' )+ + |
+ ||
| 319 | +4x | +
+ lbl |
||
| 73 | +320 |
- #'+ } |
||
| 74 | +321 |
- #' # Use a global constant model. This is helpful as a reference for the subgroup models.+ |
||
| 75 | +322 |
- #' step_matrix3 <- fit_rsp_step(+ #' Indicate study arm variable in formula |
||
| 76 | +323 |
- #' variables = variables,+ #' |
||
| 77 | +324 |
- #' data = adrs_f,+ #' We use `study_arm` to indicate the study arm variable in `tern` formulas. |
||
| 78 | +325 |
- #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L))+ #' |
||
| 79 | +326 |
- #' )+ #' @param x arm information |
||
| 80 | +327 |
#' |
||
| 81 | +328 |
- #' # It is also possible to use strata, i.e. use conditional logistic regression models.+ #' @return `x` |
||
| 82 | +329 |
- #' variables2 <- list(+ #' |
||
| 83 | +330 |
- #' arm = "ARM",+ #' @keywords internal |
||
| 84 | +331 |
- #' biomarker = "BMRKR1",+ study_arm <- function(x) {
+ |
+ ||
| 332 | +! | +
+ structure(x, varname = deparse(substitute(x))) |
||
| 85 | +333 |
- #' covariates = "AGE",+ } |
||
| 86 | +334 |
- #' response = "RSP",+ |
||
| 87 | +335 |
- #' strata = c("STRATA1", "STRATA2")
+ #' Smooth function with optional grouping |
||
| 88 | +336 |
- #' )+ #' |
||
| 89 | +337 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 338 |
#' |
|||
| 90 | +339 |
- #' step_matrix4 <- fit_rsp_step(+ #' This produces `loess` smoothed estimates of `y` with Student confidence intervals. |
||
| 91 | +340 |
- #' variables = variables2,+ #' |
||
| 92 | +341 |
- #' data = adrs_f,+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
||
| 93 | +342 |
- #' control = c(control_logistic(), control_step(bandwidth = NULL))+ #' @param x (`string`)\cr x column name. |
||
| 94 | +343 |
- #' )+ #' @param y (`string`)\cr y column name. |
||
| 95 | +344 | ++ |
+ #' @param groups (`character` or `NULL`)\cr vector with optional grouping variables names.+ |
+ |
| 345 | ++ |
+ #' @param level (`proportion`)\cr level of confidence interval to use (0.95 by default).+ |
+ ||
| 346 |
#' |
|||
| 96 | +347 |
- #' @export+ #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and |
||
| 97 | +348 |
- fit_rsp_step <- function(variables,+ #' optional `groups` variables formatted as `factor` type. |
||
| 98 | +349 |
- data,+ #' |
||
| 99 | +350 |
- control = c(control_step(), control_logistic())) {
+ #' @export+ |
+ ||
| 351 | ++ |
+ get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
|
||
| 100 | +352 | 5x |
- assert_df_with_variables(data, variables)+ checkmate::assert_data_frame(df) |
|
| 101 | +353 | 5x |
- checkmate::assert_list(control, names = "named")+ df_cols <- colnames(df) |
|
| 102 | +354 | 5x |
- data <- data[!is.na(data[[variables$biomarker]]), ]+ checkmate::assert_string(x) |
|
| 103 | +355 | 5x |
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ checkmate::assert_subset(x, df_cols) |
|
| 104 | +356 | 5x |
- interval_center <- window_sel$interval[, "Interval Center"]+ checkmate::assert_numeric(df[[x]]) |
|
| 105 | +357 | 5x |
- form <- h_step_rsp_formula(variables = variables, control = control)+ checkmate::assert_string(y) |
|
| 106 | +358 | 5x |
- estimates <- if (is.null(control$bandwidth)) {
+ checkmate::assert_subset(y, df_cols) |
|
| 107 | -1x | +359 | +5x |
- h_step_rsp_est(+ checkmate::assert_numeric(df[[y]])+ |
+
| 360 | ++ | + | ||
| 108 | -1x | +361 | +5x |
- formula = form,+ if (!is.null(groups)) {
|
| 109 | -1x | +362 | +4x |
- data = data,+ checkmate::assert_character(groups) |
| 110 | -1x | +363 | +4x |
- variables = variables,+ checkmate::assert_subset(groups, df_cols)+ |
+
| 364 | ++ |
+ }+ |
+ ||
| 365 | ++ | + | ||
| 111 | -1x | +366 | +5x |
- x = interval_center,+ smooths <- function(x, y) {
|
| 112 | -1x | +367 | +18x |
- control = control+ stats::predict(stats::loess(y ~ x), se = TRUE) |
| 113 | +368 |
- )+ } |
||
| 114 | +369 |
- } else {
+
|
||
| 115 | +370 | +5x | +
+ if (!is.null(groups)) {
+ |
+ |
| 371 | 4x |
- tmp <- mapply(+ cc <- stats::complete.cases(df[c(x, y, groups)]) |
||
| 116 | +372 | 4x |
- FUN = h_step_rsp_est,+ df_c <- df[cc, c(x, y, groups)] |
|
| 117 | +373 | 4x |
- x = interval_center,+ df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
|
|
| 118 | +374 | 4x |
- subset = as.list(as.data.frame(window_sel$sel)),+ df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))+ |
+ |
| 375 | ++ | + | ||
| 119 | +376 | 4x |
- MoreArgs = list(+ df_smooth_raw <- |
|
| 120 | +377 | 4x |
- formula = form,+ by(df_c_ordered, df_c_g, function(d) {
|
|
| 121 | +378 | +17x | +
+ plx <- smooths(d[[x]], d[[y]])+ |
+ |
| 379 | +17x | +
+ data.frame(+ |
+ ||
| 380 | +17x | +
+ x = d[[x]],+ |
+ ||
| 381 | +17x | +
+ y = plx$fit,+ |
+ ||
| 382 | +17x | +
+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ |
+ ||
| 383 | +17x | +
+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ |
+ ||
| 384 | ++ |
+ )+ |
+ ||
| 385 | ++ |
+ })+ |
+ ||
| 386 | ++ | + + | +||
| 387 | 4x |
- data = data,+ df_smooth <- do.call(rbind, df_smooth_raw) |
||
| 122 | +388 | 4x |
- variables = variables,+ df_smooth[groups] <- df_c_g+ |
+ |
| 389 | ++ | + | ||
| 123 | +390 | 4x |
- control = control+ df_smooth |
|
| 124 | +391 |
- )+ } else {
+ |
+ ||
| 392 | +1x | +
+ cc <- stats::complete.cases(df[c(x, y)])+ |
+ ||
| 393 | +1x | +
+ df_c <- df[cc, ]+ |
+ ||
| 394 | +1x | +
+ plx <- smooths(df_c[[x]], df_c[[y]]) |
||
| 125 | +395 | ++ | + + | +|
| 396 | +1x | +
+ df_smooth <- data.frame(+ |
+ ||
| 397 | +1x | +
+ x = df_c[[x]],+ |
+ ||
| 398 | +1x | +
+ y = plx$fit,+ |
+ ||
| 399 | +1x | +
+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ |
+ ||
| 400 | +1x | +
+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ |
+ ||
| 401 |
) |
|||
| 126 | +402 |
- # Maybe we find a more elegant solution than this.+ |
||
| 127 | -4x | +403 | +1x |
- rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
+ df_smooth+ |
+
| 404 | ++ |
+ }+ |
+ ||
| 405 | ++ |
+ }+ |
+ ||
| 406 | ++ | + + | +||
| 407 | ++ |
+ #' Number of available (non-missing entries) in a vector+ |
+ ||
| 408 | ++ |
+ #'+ |
+ ||
| 409 | ++ |
+ #' Small utility function for better readability.+ |
+ ||
| 410 | ++ |
+ #'+ |
+ ||
| 411 | ++ |
+ #' @param x (`vector`)\cr vector in which to count non-missing values.+ |
+ ||
| 412 | ++ |
+ #'+ |
+ ||
| 413 | ++ |
+ #' @return Number of non-missing values.+ |
+ ||
| 414 | ++ |
+ #'+ |
+ ||
| 415 | ++ |
+ #' @keywords internal+ |
+ ||
| 416 | ++ |
+ n_available <- function(x) {
|
||
| 128 | -4x | +417 | +355x |
- t(tmp)+ sum(!is.na(x)) |
| 129 | +418 |
- }+ }+ |
+ ||
| 419 | ++ | + + | +||
| 420 | ++ |
+ #' Reapply variable labels+ |
+ ||
| 421 | ++ |
+ #'+ |
+ ||
| 422 | ++ |
+ #' This is a helper function that is used in tests.+ |
+ ||
| 423 | ++ |
+ #'+ |
+ ||
| 424 | ++ |
+ #' @param x (`vector`)\cr vector of elements that needs new labels.+ |
+ ||
| 425 | ++ |
+ #' @param varlabels (`character`)\cr vector of labels for `x`.+ |
+ ||
| 426 | ++ |
+ #' @param ... further parameters to be added to the list.+ |
+ ||
| 427 | ++ |
+ #'+ |
+ ||
| 428 | ++ |
+ #' @return `x` with variable labels reapplied.+ |
+ ||
| 429 | ++ |
+ #'+ |
+ ||
| 430 | ++ |
+ #' @export+ |
+ ||
| 431 | ++ |
+ reapply_varlabels <- function(x, varlabels, ...) {
|
||
| 130 | -5x | +432 | +11x |
- result <- cbind(window_sel$interval, estimates)+ named_labels <- c(as.list(varlabels), list(...)) |
| 131 | -5x | +433 | +11x |
- structure(+ formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels) |
| 132 | -5x | +434 | +11x |
- result,+ x+ |
+
| 435 | ++ |
+ }+ |
+ ||
| 436 | ++ | + + | +||
| 437 | ++ |
+ # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show+ |
+ ||
| 438 | ++ |
+ clogit_with_tryCatch <- function(formula, data, ...) { # nolint
|
||
| 133 | -5x | +439 | +33x |
- class = c("step", "matrix"),
+ tryCatch( |
| 134 | -5x | +440 | +33x |
- variables = variables,+ survival::clogit(formula = formula, data = data, ...), |
| 135 | -5x | +441 | +33x |
- control = control+ error = function(e) stop("model not built successfully with survival::clogit")
|
| 136 | +442 |
) |
||
| 137 | +443 |
}@@ -148842,14 +147622,14 @@ tern coverage - 95.65% |
| 1 |
- #' Survival time point analysis+ #' Count patients with abnormal analysis range values by baseline status |
||
| 5 |
- #' The analyze function [surv_timepoint()] creates a layout element to analyze patient survival rates and difference+ #' The analyze function [count_abnormal_by_baseline()] creates a layout element to count patients with abnormal |
||
| 6 |
- #' of survival rates between groups at a given time point. The primary analysis variable `vars` is the time variable.+ #' analysis range values, categorized by baseline status. |
||
| 7 |
- #' Other required inputs are `time_point`, the numeric time point of interest, and `is_event`, a variable that+ #' |
||
| 8 |
- #' indicates whether or not an event has occurred. The `method` argument is used to specify whether you want to analyze+ #' This function analyzes primary analysis variable `var` which indicates abnormal range results. Additional |
||
| 9 |
- #' survival estimations (`"surv"`), difference in survival with the control (`"surv_diff"`), or both of these+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
||
| 10 |
- #' (`"both"`).+ #' `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` (defaults to `BNRIND`), a |
||
| 11 |
- #'+ #' variable to indicate baseline reference ranges. |
||
| 12 |
- #' @inheritParams argument_convention+ #' |
||
| 13 |
- #' @inheritParams s_surv_time+ #' For each direction specified via the `abnormal` parameter (e.g. High or Low), we condition on baseline |
||
| 14 |
- #' @param time_point (`numeric(1)`)\cr survival time point of interest.+ #' range result and count patients in the numerator and denominator as follows for each of the following |
||
| 15 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' categories: |
||
| 16 |
- #' [control_surv_timepoint()]. Some possible parameter options are:+ #' * `Not <abnormality>` |
||
| 17 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ #' * `num`: The number of patients without abnormality at baseline (excluding those with missing baseline) |
||
| 18 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ #' and with at least one abnormality post-baseline. |
||
| 19 |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ #' * `denom`: The number of patients without abnormality at baseline (excluding those with missing baseline). |
||
| 20 |
- #' @param method (`string`)\cr `"surv"` (survival estimations), `"surv_diff"` (difference in survival with the+ #' * `<Abnormality>` |
||
| 21 |
- #' control), or `"both"`.+ #' * `num`: The number of patients with abnormality as baseline and at least one abnormality post-baseline. |
||
| 22 |
- #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to+ #' * `denom`: The number of patients with abnormality at baseline. |
||
| 23 |
- #' avoid warnings from duplicate table names.+ #' * `Total` |
||
| 24 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' * `num`: The number of patients with at least one post-baseline record and at least one abnormality |
||
| 25 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' post-baseline. |
||
| 26 |
- #' for that statistic's row label.+ #' * `denom`: The number of patients with at least one post-baseline record. |
||
| 27 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' |
||
| 28 |
- #'+ #' This function assumes that `df` has been filtered to only include post-baseline records. |
||
| 29 |
- #' Options are: ``r shQuote(get_stats("surv_timepoint"))``
+ #' |
||
| 30 |
- #'+ #' @inheritParams argument_convention |
||
| 31 |
- #' @name survival_timepoint+ #' @param abnormal (`character`)\cr values identifying the abnormal range level(s) in `.var`. |
||
| 32 |
- #' @order 1+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 33 |
- NULL+ #' |
||
| 34 |
-
+ #' Options are: ``r shQuote(get_stats("abnormal_by_baseline"))``
|
||
| 35 |
- #' @describeIn survival_timepoint Statistics function which analyzes survival rate.+ #' |
||
| 36 |
- #'+ #' @note |
||
| 37 |
- #' @return+ #' * `df` should be filtered to include only post-baseline records. |
||
| 38 |
- #' * `s_surv_timepoint()` returns the statistics:+ #' * If the baseline variable or analysis variable contains `NA` records, it is expected that `df` has been |
||
| 39 |
- #' * `pt_at_risk`: Patients remaining at risk.+ #' pre-processed using [df_explicit_na()] or [explicit_na()]. |
||
| 40 |
- #' * `event_free_rate`: Event-free rate (%).+ #' |
||
| 41 |
- #' * `rate_se`: Standard error of event free rate.+ #' @seealso Relevant description function [d_count_abnormal_by_baseline()]. |
||
| 42 |
- #' * `rate_ci`: Confidence interval for event free rate.+ #' |
||
| 43 |
- #'+ #' @name abnormal_by_baseline |
||
| 44 |
- #' @keywords internal+ #' @order 1 |
||
| 45 |
- s_surv_timepoint <- function(df,+ NULL |
||
| 46 |
- .var,+ |
||
| 47 |
- time_point,+ #' Description function for `s_count_abnormal_by_baseline()` |
||
| 48 |
- is_event,+ #' |
||
| 49 |
- control = control_surv_timepoint()) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 50 | -23x | +
- checkmate::assert_string(.var)+ #' |
|
| 51 | -23x | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ #' Description function that produces the labels for [s_count_abnormal_by_baseline()]. |
|
| 52 | -23x | +
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ #' |
|
| 53 | -23x | +
- checkmate::assert_number(time_point)+ #' @inheritParams abnormal_by_baseline |
|
| 54 | -23x | +
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ #' |
|
| 55 |
-
+ #' @return Abnormal category labels for [s_count_abnormal_by_baseline()]. |
||
| 56 | -23x | +
- conf_type <- control$conf_type+ #' |
|
| 57 | -23x | +
- conf_level <- control$conf_level+ #' @examples |
|
| 58 |
-
+ #' d_count_abnormal_by_baseline("LOW")
|
||
| 59 | -23x | +
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ #' |
|
| 60 | -23x | +
- srv_fit <- survival::survfit(+ #' @export |
|
| 61 | -23x | +
- formula = formula,+ d_count_abnormal_by_baseline <- function(abnormal) {
|
|
| 62 | -23x | +9x |
- data = df,+ not_abn_name <- paste("Not", tolower(abnormal))
|
| 63 | -23x | +9x |
- conf.int = conf_level,+ abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2))) |
| 64 | -23x | +9x |
- conf.type = conf_type+ total_name <- "Total" |
| 65 |
- )+ |
||
| 66 | -23x | +9x |
- s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE)+ list( |
| 67 | -23x | +9x |
- df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
+ not_abnormal = not_abn_name, |
| 68 | -23x | +9x |
- if (df_srv_fit[["n.risk"]] == 0) {
+ abnormal = abn_name, |
| 69 | -1x | +9x |
- pt_at_risk <- event_free_rate <- rate_se <- NA_real_+ total = total_name |
| 70 | -1x | +
- rate_ci <- c(NA_real_, NA_real_)+ ) |
|
| 71 |
- } else {
+ } |
||
| 72 | -22x | +
- pt_at_risk <- df_srv_fit$n.risk+ |
|
| 73 | -22x | +
- event_free_rate <- df_srv_fit$surv+ #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level. |
|
| 74 | -22x | +
- rate_se <- df_srv_fit$std.err+ #' |
|
| 75 | -22x | +
- rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)+ #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with |
|
| 76 |
- }+ #' [df_explicit_na()]). The default is `"<Missing>"`. |
||
| 77 | -23x | +
- list(+ #' |
|
| 78 | -23x | +
- pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),+ #' @return |
|
| 79 | -23x | +
- event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),+ #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements: |
|
| 80 | -23x | +
- rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),+ #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts. |
|
| 81 | -23x | +
- rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level))+ #' |
|
| 82 |
- )+ #' @keywords internal |
||
| 83 |
- }+ s_count_abnormal_by_baseline <- function(df, |
||
| 84 |
-
+ .var, |
||
| 85 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ abnormal, |
||
| 86 |
- #' when `method = "surv"`.+ na_str = "<Missing>", |
||
| 87 |
- #'+ variables = list(id = "USUBJID", baseline = "BNRIND")) {
|
||
| 88 | -+ | 7x |
- #' @return+ checkmate::assert_string(.var) |
| 89 | -+ | 7x |
- #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()].+ checkmate::assert_string(abnormal) |
| 90 | -+ | 7x |
- #'+ checkmate::assert_string(na_str) |
| 91 | -+ | 7x |
- #' @keywords internal+ assert_df_with_variables(df, c(range = .var, variables)) |
| 92 | -+ | 7x |
- a_surv_timepoint <- make_afun(+ checkmate::assert_subset(names(variables), c("id", "baseline"))
|
| 93 | -+ | 7x |
- s_surv_timepoint,+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 94 | -+ | 7x |
- .indent_mods = c(+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
| 95 | -+ | 7x |
- pt_at_risk = 0L,+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 96 |
- event_free_rate = 0L,+ |
||
| 97 |
- rate_se = 1L,+ # If input is passed as character, changed to factor |
||
| 98 | -+ | 7x |
- rate_ci = 1L+ df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str) |
| 99 | -+ | 7x |
- ),+ df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str) |
| 100 |
- .formats = c(+ |
||
| 101 | -+ | 7x |
- pt_at_risk = "xx",+ assert_valid_factor(df[[.var]], any.missing = FALSE) |
| 102 | -+ | 6x |
- event_free_rate = "xx.xx",+ assert_valid_factor(df[[variables$baseline]], any.missing = FALSE) |
| 103 |
- rate_se = "xx.xx",+ |
||
| 104 |
- rate_ci = "(xx.xx, xx.xx)"+ # Keep only records with valid analysis value. |
||
| 105 | -+ | 5x |
- )+ df <- df[df[[.var]] != na_str, ] |
| 106 |
- )+ |
||
| 107 | -+ | 5x |
-
+ anl <- data.frame( |
| 108 | -+ | 5x |
- #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates.+ id = df[[variables$id]], |
| 109 | -+ | 5x |
- #'+ var = df[[.var]], |
| 110 | -+ | 5x |
- #' @return+ baseline = df[[variables$baseline]], |
| 111 | -+ | 5x |
- #' * `s_surv_timepoint_diff()` returns the statistics:+ stringsAsFactors = FALSE |
| 112 |
- #' * `rate_diff`: Event-free rate difference between two groups.+ ) |
||
| 113 |
- #' * `rate_diff_ci`: Confidence interval for the difference.+ |
||
| 114 |
- #' * `ztest_pval`: p-value to test the difference is 0.+ # Total: |
||
| 115 |
- #'+ # - Patients in denominator: have at least one valid measurement post-baseline. |
||
| 116 |
- #' @keywords internal+ # - Patients in numerator: have at least one abnormality. |
||
| 117 | -+ | 5x |
- s_surv_timepoint_diff <- function(df,+ total_denom <- length(unique(anl$id)) |
| 118 | -+ | 5x |
- .var,+ total_num <- length(unique(anl$id[anl$var == abnormal])) |
| 119 |
- .ref_group,+ |
||
| 120 |
- .in_ref_col,+ # Baseline NA records are counted only in total rows. |
||
| 121 | -+ | 5x |
- time_point,+ anl <- anl[anl$baseline != na_str, ] |
| 122 |
- control = control_surv_timepoint(),+ |
||
| 123 |
- ...) {
+ # Abnormal: |
||
| 124 | -2x | +
- if (.in_ref_col) {
+ # - Patients in denominator: have abnormality at baseline. |
|
| 125 | -! | +
- return(+ # - Patients in numerator: have abnormality at baseline AND |
|
| 126 | -! | +
- list(+ # have at least one abnormality post-baseline. |
|
| 127 | -! | +5x |
- rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
+ abn_denom <- length(unique(anl$id[anl$baseline == abnormal])) |
| 128 | -! | +5x |
- rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal])) |
| 129 | -! | +
- ztest_pval = formatters::with_label("", "p-value (Z-test)")
+
|
|
| 130 |
- )+ # Not abnormal: |
||
| 131 |
- )+ # - Patients in denominator: do not have abnormality at baseline. |
||
| 132 |
- }+ # - Patients in numerator: do not have abnormality at baseline AND |
||
| 133 | -2x | +
- data <- rbind(.ref_group, df)+ # have at least one abnormality post-baseline. |
|
| 134 | -2x | +5x |
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal])) |
| 135 | -2x | +5x |
- res_per_group <- lapply(split(data, group), function(x) {
+ not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal])) |
| 136 | -4x | +
- s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...)+ |
|
| 137 | -+ | 5x |
- })+ labels <- d_count_abnormal_by_baseline(abnormal) |
| 138 | -+ | 5x |
-
+ list(fraction = list( |
| 139 | -2x | +5x |
- res_x <- res_per_group[[2]]+ not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal), |
| 140 | -2x | +5x |
- res_ref <- res_per_group[[1]]+ abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal), |
| 141 | -2x | +5x |
- rate_diff <- res_x$event_free_rate - res_ref$event_free_rate+ total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total) |
| 142 | -2x | +
- se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2)+ )) |
|
| 143 |
-
+ } |
||
| 144 | -2x | +
- qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2)+ |
|
| 145 | -2x | +
- rate_diff_ci <- rate_diff + qs * se_diff+ #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun` |
|
| 146 | -2x | +
- ztest_pval <- if (is.na(rate_diff)) {
+ #' in `count_abnormal_by_baseline()`. |
|
| 147 | -2x | +
- NA+ #' |
|
| 148 |
- } else {
+ #' @return |
||
| 149 | -2x | +
- 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff))+ #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 150 |
- }+ #' |
||
| 151 | -2x | +
- list(+ #' @keywords internal |
|
| 152 | -2x | +
- rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),+ a_count_abnormal_by_baseline <- make_afun( |
|
| 153 | -2x | +
- rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),+ s_count_abnormal_by_baseline, |
|
| 154 | -2x | +
- ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)")+ .formats = c(fraction = format_fraction) |
|
| 155 |
- )+ ) |
||
| 156 |
- }+ |
||
| 157 |
-
+ #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments |
||
| 158 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 159 |
- #' when `method = "surv_diff"`.+ #' |
||
| 160 |
- #'+ #' @return |
||
| 161 |
- #' @return+ #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions, |
||
| 162 |
- #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 163 |
- #'+ #' the statistics from `s_count_abnormal_by_baseline()` to the table layout. |
||
| 164 |
- #' @keywords internal+ #' |
||
| 165 |
- a_surv_timepoint_diff <- make_afun(+ #' @examples |
||
| 166 |
- s_surv_timepoint_diff,+ #' df <- data.frame( |
||
| 167 |
- .formats = c(+ #' USUBJID = as.character(c(1:6)), |
||
| 168 |
- rate_diff = "xx.xx",+ #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
|
||
| 169 |
- rate_diff_ci = "(xx.xx, xx.xx)",+ #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
|
||
| 170 |
- ztest_pval = "x.xxxx | (<0.0001)"+ #' ) |
||
| 171 |
- )+ #' df <- df_explicit_na(df) |
||
| 172 |
- )+ #' |
||
| 173 |
-
+ #' # Layout creating function. |
||
| 174 |
- #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments+ #' basic_table() %>% |
||
| 175 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>% |
||
| 176 |
- #'+ #' build_table(df) |
||
| 177 |
- #' @return+ #' |
||
| 178 |
- #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions,+ #' # Passing of statistics function and formatting arguments. |
||
| 179 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' df2 <- data.frame( |
||
| 180 |
- #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on+ #' ID = as.character(c(1, 2, 3, 4)), |
||
| 181 |
- #' the value of `method`.+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 182 |
- #'+ #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
|
||
| 183 |
- #' @examples+ #' ) |
||
| 184 |
- #' library(dplyr)+ #' |
||
| 185 |
- #'+ #' basic_table() %>% |
||
| 186 |
- #' adtte_f <- tern_ex_adtte %>%+ #' count_abnormal_by_baseline( |
||
| 187 |
- #' filter(PARAMCD == "OS") %>%+ #' var = "RANGE", |
||
| 188 |
- #' mutate(+ #' abnormal = c(Low = "LOW"), |
||
| 189 |
- #' AVAL = day2month(AVAL),+ #' variables = list(id = "ID", baseline = "BLRANGE"), |
||
| 190 |
- #' is_event = CNSR == 0+ #' .formats = c(fraction = "xx / xx"), |
||
| 191 |
- #' )+ #' .indent_mods = c(fraction = 2L) |
||
| 192 |
- #'+ #' ) %>% |
||
| 193 |
- #' # Survival at given time points.+ #' build_table(df2) |
||
| 194 |
- #' basic_table() %>%+ #' |
||
| 195 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' @export |
||
| 196 |
- #' add_colcounts() %>%+ #' @order 2 |
||
| 197 |
- #' surv_timepoint(+ count_abnormal_by_baseline <- function(lyt, |
||
| 198 |
- #' vars = "AVAL",+ var, |
||
| 199 |
- #' var_labels = "Months",+ abnormal, |
||
| 200 |
- #' is_event = "is_event",+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 201 |
- #' time_point = 7+ na_str = "<Missing>", |
||
| 202 |
- #' ) %>%+ nested = TRUE, |
||
| 203 |
- #' build_table(df = adtte_f)+ ..., |
||
| 204 |
- #'+ table_names = abnormal, |
||
| 205 |
- #' # Difference in survival at given time points.+ .stats = NULL, |
||
| 206 |
- #' basic_table() %>%+ .formats = NULL, |
||
| 207 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ .labels = NULL, |
||
| 208 |
- #' add_colcounts() %>%+ .indent_mods = NULL) {
|
||
| 209 | -+ | 2x |
- #' surv_timepoint(+ checkmate::assert_character(abnormal, len = length(table_names), names = "named") |
| 210 | -+ | 2x |
- #' vars = "AVAL",+ checkmate::assert_string(var) |
| 211 |
- #' var_labels = "Months",+ |
||
| 212 | -+ | 2x |
- #' is_event = "is_event",+ extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...) |
| 213 |
- #' time_point = 9,+ |
||
| 214 | -+ | 2x |
- #' method = "surv_diff",+ afun <- make_afun( |
| 215 | -+ | 2x |
- #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
+ a_count_abnormal_by_baseline, |
| 216 | -+ | 2x |
- #' ) %>%+ .stats = .stats, |
| 217 | -+ | 2x |
- #' build_table(df = adtte_f)+ .formats = .formats, |
| 218 | -+ | 2x |
- #'+ .labels = .labels, |
| 219 | -+ | 2x |
- #' # Survival and difference in survival at given time points.+ .indent_mods = .indent_mods, |
| 220 | -+ | 2x |
- #' basic_table() %>%+ .ungroup_stats = "fraction" |
| 221 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ ) |
||
| 222 | -+ | 2x |
- #' add_colcounts() %>%+ for (i in seq_along(abnormal)) {
|
| 223 | -+ | 4x |
- #' surv_timepoint(+ extra_args[["abnormal"]] <- abnormal[i] |
| 224 |
- #' vars = "AVAL",+ |
||
| 225 | -+ | 4x |
- #' var_labels = "Months",+ lyt <- analyze( |
| 226 | -+ | 4x |
- #' is_event = "is_event",+ lyt = lyt, |
| 227 | -+ | 4x |
- #' time_point = 9,+ vars = var, |
| 228 | -+ | 4x |
- #' method = "both"+ var_labels = names(abnormal[i]), |
| 229 | -+ | 4x |
- #' ) %>%+ afun = afun, |
| 230 | -+ | 4x |
- #' build_table(df = adtte_f)+ na_str = na_str, |
| 231 | -+ | 4x |
- #'+ nested = nested, |
| 232 | -+ | 4x |
- #' @export+ table_names = table_names[i], |
| 233 | -+ | 4x |
- #' @order 2+ extra_args = extra_args, |
| 234 | -+ | 4x |
- surv_timepoint <- function(lyt,+ show_labels = "visible" |
| 235 |
- vars,+ ) |
||
| 236 |
- time_point,+ } |
||
| 237 | -+ | 2x |
- is_event,+ lyt |
| 238 |
- control = control_surv_timepoint(),+ } |
| 239 | +1 |
- method = c("surv", "surv_diff", "both"),
+ #' Helper functions for accessing information from `rtables` |
||
| 240 | +2 |
- na_str = default_na_str(),+ #' |
||
| 241 | +3 |
- nested = TRUE,+ #' @description `r lifecycle::badge("stable")`
|
||
| 242 | +4 |
- ...,+ #' |
||
| 243 | +5 |
- table_names_suffix = "",+ #' These are a couple of functions that help with accessing the data in `rtables` objects. |
||
| 244 | +6 |
- var_labels = "Time",+ #' Currently these work for occurrence tables, which are defined as having a count as the first |
||
| 245 | +7 |
- show_labels = "visible",+ #' element and a fraction as the second element in each cell. |
||
| 246 | +8 |
- .stats = c(+ #' |
||
| 247 | +9 |
- "pt_at_risk", "event_free_rate", "rate_ci",+ #' @seealso [prune_occurrences] for usage of these functions. |
||
| 248 | +10 |
- "rate_diff", "rate_diff_ci", "ztest_pval"+ #' |
||
| 249 | +11 |
- ),+ #' @name rtables_access |
||
| 250 | +12 |
- .formats = NULL,+ NULL |
||
| 251 | +13 |
- .labels = NULL,+ |
||
| 252 | +14 |
- .indent_mods = if (method == "both") {
- |
- ||
| 253 | -2x | -
- c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L)+ #' @describeIn rtables_access Helper function to extract the first values from each content |
||
| 254 | +15 |
- } else {
- |
- ||
| 255 | -4x | -
- c(rate_diff_ci = 1L, ztest_pval = 1L)+ #' cell and from specified columns in a `TableRow`. Defaults to all columns. |
||
| 256 | +16 |
- }) {
+ #' |
||
| 257 | -6x | +|||
| 17 | +
- method <- match.arg(method)+ #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table. |
|||
| 258 | -6x | +|||
| 18 | +
- checkmate::assert_string(table_names_suffix)+ #' @param col_names (`character`)\cr the names of the columns to extract from. |
|||
| 259 | +19 |
-
+ #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided, |
||
| 260 | -6x | +|||
| 20 | +
- extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...)+ #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single |
|||
| 261 | +21 |
-
+ #' column split. |
||
| 262 | -6x | +|||
| 22 | +
- f <- list(+ #' |
|||
| 263 | -6x | +|||
| 23 | +
- surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ #' @return |
|||
| 264 | -6x | +|||
| 24 | +
- surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ #' * `h_row_first_values()` returns a `vector` of numeric values. |
|||
| 265 | +25 |
- )+ #' |
||
| 266 | -6x | +|||
| 26 | +
- .stats <- h_split_param(.stats, .stats, f = f)+ #' @examples |
|||
| 267 | -6x | +|||
| 27 | +
- .formats <- h_split_param(.formats, names(.formats), f = f)+ #' tbl <- basic_table() %>% |
|||
| 268 | -6x | +|||
| 28 | +
- .labels <- h_split_param(.labels, names(.labels), f = f)+ #' split_cols_by("ARM") %>%
|
|||
| 269 | -6x | +|||
| 29 | +
- .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f)+ #' split_rows_by("RACE") %>%
|
|||
| 270 | +30 |
-
+ #' analyze("AGE", function(x) {
|
||
| 271 | -6x | +|||
| 31 | +
- afun_surv <- make_afun(+ #' list( |
|||
| 272 | -6x | +|||
| 32 | +
- a_surv_timepoint,+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"), |
|||
| 273 | -6x | +|||
| 33 | +
- .stats = .stats$surv,+ #' "n" = length(x), |
|||
| 274 | -6x | +|||
| 34 | +
- .formats = .formats$surv,+ #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)") |
|||
| 275 | -6x | +|||
| 35 | +
- .labels = .labels$surv,+ #' ) |
|||
| 276 | -6x | +|||
| 36 | +
- .indent_mods = .indent_mods$surv+ #' }) %>% |
|||
| 277 | +37 |
- )+ #' build_table(tern_ex_adsl) %>% |
||
| 278 | +38 |
-
+ #' prune_table() |
||
| 279 | -6x | +|||
| 39 | +
- afun_surv_diff <- make_afun(+ #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]] |
|||
| 280 | -6x | +|||
| 40 | +
- a_surv_timepoint_diff,+ #' result <- max(h_row_first_values(tree_row_elem)) |
|||
| 281 | -6x | +|||
| 41 | +
- .stats = .stats$surv_diff,+ #' result |
|||
| 282 | -6x | +|||
| 42 | +
- .formats = .formats$surv_diff,+ #' |
|||
| 283 | -6x | +|||
| 43 | +
- .labels = .labels$surv_diff,+ #' @export |
|||
| 284 | -6x | +|||
| 44 | +
- .indent_mods = .indent_mods$surv_diff+ h_row_first_values <- function(table_row, |
|||
| 285 | +45 |
- )+ col_names = NULL, |
||
| 286 | +46 |
-
+ col_indices = NULL) {
|
||
| 287 | -6x | -
- time_point <- extra_args$time_point- |
- ||
| 288 | -+ | 47 | +745x |
-
+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
| 289 | -6x | +48 | +744x |
- for (i in seq_along(time_point)) {
+ checkmate::assert_integerish(col_indices) |
| 290 | -6x | +49 | +744x |
- extra_args[["time_point"]] <- time_point[i]+ checkmate::assert_subset(col_indices, seq_len(ncol(table_row))) |
| 291 | +50 | |||
| 292 | -6x | +|||
| 51 | +
- if (method %in% c("surv", "both")) {
+ # Main values are extracted |
|||
| 293 | -4x | +52 | +744x |
- lyt <- analyze(+ row_vals <- row_values(table_row)[col_indices] |
| 294 | -4x | +|||
| 53 | +
- lyt,+ |
|||
| 295 | -4x | +|||
| 54 | +
- vars,+ # Main return |
|||
| 296 | -4x | +55 | +744x |
- var_labels = paste(time_point[i], var_labels),+ vapply(row_vals, function(rv) {
|
| 297 | -4x | +56 | +2096x |
- table_names = paste0("surv_", time_point[i], table_names_suffix),
+ if (is.null(rv)) {
|
| 298 | -4x | +57 | +744x |
- show_labels = show_labels,+ NA_real_ |
| 299 | -4x | +|||
| 58 | +
- afun = afun_surv,+ } else {
|
|||
| 300 | -4x | +59 | +2090x |
- na_str = na_str,+ rv[1L] |
| 301 | -4x | +|||
| 60 | +
- nested = nested,+ } |
|||
| 302 | -4x | +61 | +744x |
- extra_args = extra_args+ }, FUN.VALUE = numeric(1)) |
| 303 | +62 |
- )+ } |
||
| 304 | +63 |
- }+ |
||
| 305 | +64 |
-
+ #' @describeIn rtables_access Helper function that extracts row values and checks if they are |
||
| 306 | -6x | +|||
| 65 | +
- if (method %in% c("surv_diff", "both")) {
+ #' convertible to integers (`integerish` values). |
|||
| 307 | -4x | +|||
| 66 | +
- lyt <- analyze(+ #' |
|||
| 308 | -4x | +|||
| 67 | +
- lyt,+ #' @return |
|||
| 309 | -4x | +|||
| 68 | +
- vars,+ #' * `h_row_counts()` returns a `vector` of numeric values. |
|||
| 310 | -4x | +|||
| 69 | +
- var_labels = paste(time_point[i], var_labels),+ #' |
|||
| 311 | -4x | +|||
| 70 | +
- table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
+ #' @examples |
|||
| 312 | -4x | +|||
| 71 | +
- show_labels = ifelse(method == "both", "hidden", show_labels),+ #' # Row counts (integer values) |
|||
| 313 | -4x | +|||
| 72 | +
- afun = afun_surv_diff,+ #' # h_row_counts(tree_row_elem) # Fails because there are no integers |
|||
| 314 | -4x | +|||
| 73 | +
- na_str = na_str,+ #' # Using values with integers |
|||
| 315 | -4x | +|||
| 74 | +
- nested = nested,+ #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]] |
|||
| 316 | -4x | +|||
| 75 | +
- extra_args = extra_args+ #' result <- h_row_counts(tree_row_elem) |
|||
| 317 | +76 |
- )+ #' # result |
||
| 318 | +77 |
- }+ #' |
||
| 319 | +78 |
- }+ #' @export+ |
+ ||
| 79 | ++ |
+ h_row_counts <- function(table_row,+ |
+ ||
| 80 | ++ |
+ col_names = NULL,+ |
+ ||
| 81 | ++ |
+ col_indices = NULL) {
|
||
| 320 | -6x | +82 | +741x |
- lyt+ counts <- h_row_first_values(table_row, col_names, col_indices)+ |
+
| 83 | +741x | +
+ checkmate::assert_integerish(counts)+ |
+ ||
| 84 | +741x | +
+ counts |
||
| 321 | +85 |
} |
| 1 | +86 |
- #' Missing data+ |
||
| 2 | +87 |
- #'+ #' @describeIn rtables_access Helper function to extract fractions from specified columns in a `TableRow`. |
||
| 3 | +88 |
- #' @description `r lifecycle::badge("stable")`
+ #' More specifically it extracts the second values from each content cell and checks it is a fraction. |
||
| 4 | +89 |
#' |
||
| 5 | +90 |
- #' Substitute missing data with a string or factor level.+ #' @return |
||
| 6 | +91 | ++ |
+ #' * `h_row_fractions()` returns a `vector` of proportions.+ |
+ |
| 92 |
#' |
|||
| 7 | +93 |
- #' @param x (`factor` or `character`)\cr values for which any missing values should be substituted.+ #' @examples |
||
| 8 | +94 |
- #' @param label (`string`)\cr string that missing data should be replaced with.+ #' # Row fractions |
||
| 9 | +95 |
- #'+ #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]] |
||
| 10 | +96 |
- #' @return `x` with any `NA` values substituted by `label`.+ #' h_row_fractions(tree_row_elem) |
||
| 11 | +97 |
#' |
||
| 12 | +98 |
- #' @examples+ #' @export |
||
| 13 | +99 |
- #' explicit_na(c(NA, "a", "b"))+ h_row_fractions <- function(table_row, |
||
| 14 | +100 |
- #' is.na(explicit_na(c(NA, "a", "b")))+ col_names = NULL, |
||
| 15 | +101 |
- #'+ col_indices = NULL) {
+ |
+ ||
| 102 | +250x | +
+ col_indices <- check_names_indices(table_row, col_names, col_indices)+ |
+ ||
| 103 | +250x | +
+ row_vals <- row_values(table_row)[col_indices]+ |
+ ||
| 104 | +250x | +
+ fractions <- sapply(row_vals, "[", 2L)+ |
+ ||
| 105 | +250x | +
+ checkmate::assert_numeric(fractions, lower = 0, upper = 1)+ |
+ ||
| 106 | +250x | +
+ fractions |
||
| 16 | +107 |
- #' explicit_na(factor(c(NA, "a", "b")))+ } |
||
| 17 | +108 |
- #' is.na(explicit_na(factor(c(NA, "a", "b"))))+ |
||
| 18 | +109 | ++ |
+ #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table.+ |
+ |
| 110 |
#' |
|||
| 19 | +111 |
- #' explicit_na(sas_na(c("a", "")))
+ #' @param table (`VTableNodeInfo`)\cr an occurrence table or row. |
||
| 20 | +112 |
#' |
||
| 21 | +113 |
- #' @export+ #' @return |
||
| 22 | +114 |
- explicit_na <- function(x, label = "<Missing>") {
+ #' * `h_col_counts()` returns a `vector` of column counts. |
||
| 23 | -254x | +|||
| 115 | +
- checkmate::assert_string(label)+ #' |
|||
| 24 | +116 |
-
+ #' @export |
||
| 25 | -254x | +|||
| 117 | +
- if (is.factor(x)) {
+ h_col_counts <- function(table, |
|||
| 26 | -151x | +|||
| 118 | +
- x <- forcats::fct_na_value_to_level(x, label)+ col_names = NULL, |
|||
| 27 | -151x | +|||
| 119 | +
- forcats::fct_drop(x, only = label)+ col_indices = NULL) {
|
|||
| 28 | -103x | +120 | +307x |
- } else if (is.character(x)) {
+ col_indices <- check_names_indices(table, col_names, col_indices) |
| 29 | -103x | +121 | +307x |
- x[is.na(x)] <- label+ counts <- col_counts(table)[col_indices] |
| 30 | -103x | +122 | +307x |
- x+ stats::setNames(counts, col_names) |
| 31 | +123 |
- } else {
+ } |
||
| 32 | -! | +|||
| 124 | +
- stop("only factors and character vectors allowed")
+
|
|||
| 33 | +125 |
- }+ #' @describeIn rtables_access Helper function to get first row of content table of current table. |
||
| 34 | +126 |
- }+ #' |
||
| 35 | +127 |
-
+ #' @return |
||
| 36 | +128 |
- #' Convert strings to `NA`+ #' * `h_content_first_row()` returns a row from an `rtables` table. |
||
| 37 | +129 |
#' |
||
| 38 | +130 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 39 | +131 |
- #'+ h_content_first_row <- function(table) {
+ |
+ ||
| 132 | +27x | +
+ ct <- content_table(table)+ |
+ ||
| 133 | +27x | +
+ tree_children(ct)[[1]] |
||
| 40 | +134 |
- #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to+ } |
||
| 41 | +135 |
- #' convert these values to `NA`s.+ |
||
| 42 | +136 |
- #'+ #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree. |
||
| 43 | +137 |
- #' @inheritParams explicit_na+ #' |
||
| 44 | +138 |
- #' @param empty (`flag`)\cr if `TRUE`, empty strings get replaced by `NA`.+ #' @return |
||
| 45 | +139 |
- #' @param whitespaces (`flag`)\cr if `TRUE`, strings made from only whitespaces get replaced with `NA`.+ #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf. |
||
| 46 | +140 |
#' |
||
| 47 | +141 |
- #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of+ #' @keywords internal |
||
| 48 | +142 |
- #' `empty` and `whitespaces`.+ is_leaf_table <- function(table) {
|
||
| 49 | -+ | |||
| 143 | +168x |
- #'+ children <- tree_children(table)+ |
+ ||
| 144 | +168x | +
+ child_classes <- unique(sapply(children, class))+ |
+ ||
| 145 | +168x | +
+ identical(child_classes, "ElementaryTable") |
||
| 50 | +146 |
- #' @examples+ } |
||
| 51 | +147 |
- #' sas_na(c("1", "", " ", " ", "b"))
+
|
||
| 52 | +148 |
- #' sas_na(factor(c("", " ", "b")))
+ #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices. |
||
| 53 | +149 |
#' |
||
| 54 | +150 |
- #' is.na(sas_na(c("1", "", " ", " ", "b")))
+ #' @return |
||
| 55 | +151 |
- #'+ #' * `check_names_indices` returns column indices. |
||
| 56 | +152 |
- #' @export+ #' |
||
| 57 | +153 |
- sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
+ #' @keywords internal |
||
| 58 | -243x | +|||
| 154 | +
- checkmate::assert_flag(empty)+ check_names_indices <- function(table_row, |
|||
| 59 | -243x | +|||
| 155 | +
- checkmate::assert_flag(whitespaces)+ col_names = NULL, |
|||
| 60 | +156 |
-
+ col_indices = NULL) {
|
||
| 61 | -243x | +157 | +1302x |
- if (is.factor(x)) {
+ if (!is.null(col_names)) {
|
| 62 | -135x | +158 | +1256x |
- empty_levels <- levels(x) == ""+ if (!is.null(col_indices)) {
|
| 63 | -11x | -
- if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA- |
- ||
| 64 | -+ | 159 | +1x |
-
+ stop( |
| 65 | -135x | +160 | +1x |
- ws_levels <- grepl("^\\s+$", levels(x))
+ "Inserted both col_names and col_indices when selecting row values. ", |
| 66 | -! | +|||
| 161 | +1x |
- if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA+ "Please choose one." |
||
| 67 | +162 | - - | -||
| 68 | -135x | -
- x+ ) |
||
| 69 | -108x | +|||
| 163 | +
- } else if (is.character(x)) {
+ } |
|||
| 70 | -108x | +164 | +1255x |
- if (empty) x[x == ""] <- NA_character_+ col_indices <- h_col_indices(table_row, col_names) |
| 71 | +165 |
-
+ } |
||
| 72 | -108x | +166 | +1301x |
- if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
+ if (is.null(col_indices)) {
|
| 73 | -+ | |||
| 167 | +39x |
-
+ ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row)) |
||
| 74 | -108x | +168 | +39x |
- x+ col_indices <- seq_len(ll) |
| 75 | +169 |
- } else {
+ } |
||
| 76 | -! | +|||
| 170 | +
- stop("only factors and character vectors allowed")
+
|
|||
| 77 | -+ | |||
| 171 | +1301x |
- }+ return(col_indices) |
||
| 78 | +172 |
}@@ -151647,14 +150504,14 @@ tern coverage - 95.65% |
| 1 |
- #' Class for `CombinationFunction`+ #' Confidence interval for mean |
||
| 5 |
- #' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that+ #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the |
||
| 6 |
- #' can be combined and negated with the logical operators.+ #' geometric mean. It can be used as a `ggplot` helper function for plotting. |
||
| 8 |
- #' @param e1 (`CombinationFunction`)\cr left hand side of logical operator.+ #' @inheritParams argument_convention |
||
| 9 |
- #' @param e2 (`CombinationFunction`)\cr right hand side of logical operator.+ #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean. |
||
| 10 |
- #' @param x (`CombinationFunction`)\cr the function which should be negated.+ #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s. |
||
| 11 |
- #'+ #' @param geom_mean (`flag`)\cr whether the geometric mean should be calculated. |
||
| 12 |
- #' @return A logical value indicating whether the left hand side of the equation equals the right hand side.+ #' |
||
| 13 |
- #'+ #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`. |
||
| 14 |
- #' @examples+ #' |
||
| 15 |
- #' higher <- function(a) {
+ #' @examples |
||
| 16 |
- #' force(a)+ #' stat_mean_ci(sample(10), gg_helper = FALSE) |
||
| 17 |
- #' CombinationFunction(+ #' |
||
| 18 |
- #' function(x) {
+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 19 |
- #' x > a+ #' ggplot2::geom_point() |
||
| 20 |
- #' }+ #' |
||
| 21 |
- #' )+ #' p + ggplot2::stat_summary( |
||
| 22 |
- #' }+ #' fun.data = stat_mean_ci, |
||
| 23 |
- #'+ #' geom = "errorbar" |
||
| 24 |
- #' lower <- function(b) {
+ #' ) |
||
| 25 |
- #' force(b)+ #' |
||
| 26 |
- #' CombinationFunction(+ #' p + ggplot2::stat_summary( |
||
| 27 |
- #' function(x) {
+ #' fun.data = stat_mean_ci, |
||
| 28 |
- #' x < b+ #' fun.args = list(conf_level = 0.5), |
||
| 29 |
- #' }+ #' geom = "errorbar" |
||
| 30 |
- #' )+ #' ) |
||
| 31 |
- #' }+ #' |
||
| 32 |
- #'+ #' p + ggplot2::stat_summary( |
||
| 33 |
- #' c1 <- higher(5)+ #' fun.data = stat_mean_ci, |
||
| 34 |
- #' c2 <- lower(10)+ #' fun.args = list(conf_level = 0.5, geom_mean = TRUE), |
||
| 35 |
- #' c3 <- higher(5) & lower(10)+ #' geom = "errorbar" |
||
| 36 |
- #' c3(7)+ #' ) |
||
| 38 |
- #' @name combination_function+ #' @export |
||
| 39 |
- #' @aliases CombinationFunction-class+ stat_mean_ci <- function(x, |
||
| 40 |
- #' @exportClass CombinationFunction+ conf_level = 0.95, |
||
| 41 |
- #' @export CombinationFunction+ na.rm = TRUE, # nolint |
||
| 42 |
- CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint
+ n_min = 2, |
||
| 43 |
-
+ gg_helper = TRUE, |
||
| 44 |
- #' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions.+ geom_mean = FALSE) {
|
||
| 45 | -+ | 2283x |
- #' The resulting object is of the same class, and evaluates the two argument functions. The result+ if (na.rm) {
|
| 46 | -+ | 10x |
- #' is then the "AND" of the two individual results.+ x <- stats::na.omit(x) |
| 47 |
- #'+ } |
||
| 48 | -+ | 2283x |
- #' @export+ n <- length(x) |
| 49 |
- methods::setMethod(+ |
||
| 50 | -+ | 2283x |
- "&",+ if (!geom_mean) {
|
| 51 | -+ | 1149x |
- signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ m <- mean(x) |
| 52 |
- definition = function(e1, e2) {
+ } else {
|
||
| 53 | -4x | +1134x |
- CombinationFunction(function(...) {
+ negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0) |
| 54 | -490x | +1134x |
- e1(...) && e2(...)+ if (negative_values_exist) {
|
| 55 | -+ | 22x |
- })+ m <- NA_real_ |
| 56 |
- }+ } else {
|
||
| 57 | -+ | 1112x |
- )+ x <- log(x) |
| 58 | -+ | 1112x |
-
+ m <- mean(x) |
| 59 |
- #' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions.+ } |
||
| 60 |
- #' The resulting object is of the same class, and evaluates the two argument functions. The result+ } |
||
| 61 |
- #' is then the "OR" of the two individual results.+ |
||
| 62 | -+ | 2283x |
- #'+ if (n < n_min || is.na(m)) {
|
| 63 | -+ | 302x |
- #' @export+ ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_) |
| 64 |
- methods::setMethod(+ } else {
|
||
| 65 | -+ | 1981x |
- "|",+ hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n) |
| 66 | -+ | 1981x |
- signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci) |
| 67 | -+ | 1981x |
- definition = function(e1, e2) {
+ if (geom_mean) {
|
| 68 | -2x | +981x |
- CombinationFunction(function(...) {
+ ci <- exp(ci) |
| 69 | -4x | +
- e1(...) || e2(...)+ } |
|
| 70 |
- })+ } |
||
| 71 |
- }+ |
||
| 72 | -+ | 2283x |
- )+ if (gg_helper) {
|
| 73 | -+ | 4x |
-
+ m <- ifelse(is.na(m), NA_real_, m) |
| 74 | -+ | 4x |
- #' @describeIn combination_function Logical negation of `CombinationFunction` functions.+ ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]]) |
| 75 |
- #' The resulting object is of the same class, and evaluates the original function. The result+ } |
||
| 76 |
- #' is then the opposite of this results.+ |
||
| 77 | -+ | 2283x |
- #'+ return(ci) |
| 78 |
- #' @export+ } |
||
| 79 |
- methods::setMethod(+ |
||
| 80 |
- "!",+ #' Confidence interval for median |
||
| 81 |
- signature = c(x = "CombinationFunction"),+ #' |
||
| 82 |
- definition = function(x) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 83 | -2x | +
- CombinationFunction(function(...) {
+ #' |
|
| 84 | -305x | +
- !x(...)+ #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper |
|
| 85 |
- })+ #' function for plotting. |
||
| 86 |
- }+ #' |
||
| 87 |
- )+ #' @inheritParams argument_convention |
| 1 | +88 |
- #' Combine factor levels+ #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s. |
||
| 2 | +89 |
#' |
||
| 3 | +90 |
- #' @description `r lifecycle::badge("stable")`
+ #' @details This function was adapted from `DescTools/versions/0.99.35/source` |
||
| 4 | +91 |
#' |
||
| 5 | +92 |
- #' Combine specified old factor Levels in a single new level.+ #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`. |
||
| 6 | +93 |
#' |
||
| 7 | +94 |
- #' @param x (`factor`)\cr factor variable.+ #' @examples |
||
| 8 | +95 |
- #' @param levels (`character`)\cr level names to be combined.+ #' stat_median_ci(sample(10), gg_helper = FALSE) |
||
| 9 | +96 |
- #' @param new_level (`string`)\cr name of new level.+ #' |
||
| 10 | +97 |
- #'+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 11 | +98 |
- #' @return A `factor` with the new levels.+ #' ggplot2::geom_point() |
||
| 12 | +99 |
- #'+ #' p + ggplot2::stat_summary( |
||
| 13 | +100 |
- #' @examples+ #' fun.data = stat_median_ci, |
||
| 14 | +101 |
- #' x <- factor(letters[1:5], levels = letters[5:1])+ #' geom = "errorbar" |
||
| 15 | +102 |
- #' combine_levels(x, levels = c("a", "b"))
+ #' ) |
||
| 16 | +103 |
#' |
||
| 17 | +104 |
- #' combine_levels(x, c("e", "b"))
+ #' @export |
||
| 18 | +105 |
- #'+ stat_median_ci <- function(x, |
||
| 19 | +106 |
- #' @export+ conf_level = 0.95, |
||
| 20 | +107 |
- combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
+ na.rm = TRUE, # nolint+ |
+ ||
| 108 | ++ |
+ gg_helper = TRUE) {
|
||
| 21 | -4x | +109 | +1147x |
- checkmate::assert_factor(x)+ x <- unname(x) |
| 22 | -4x | +110 | +1147x |
- checkmate::assert_subset(levels, levels(x))+ if (na.rm) {
+ |
+
| 111 | +9x | +
+ x <- x[!is.na(x)] |
||
| 23 | +112 |
-
+ } |
||
| 24 | -4x | +113 | +1147x |
- lvls <- levels(x)+ n <- length(x)+ |
+
| 114 | +1147x | +
+ med <- stats::median(x) |
||
| 25 | +115 | |||
| 26 | -4x | +116 | +1147x |
- lvls[lvls %in% levels] <- new_level+ k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE) |
| 27 | +117 | |||
| 118 | ++ |
+ # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range+ |
+ ||
| 28 | -4x | +119 | +1147x |
- levels(x) <- lvls+ if (k == 0 || is.na(med)) {
+ |
+
| 120 | +242x | +
+ ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)+ |
+ ||
| 121 | +242x | +
+ empir_conf_level <- NA_real_ |
||
| 29 | +122 |
-
+ } else {
|
||
| 30 | -4x | +123 | +905x |
- x+ x_sort <- sort(x)+ |
+
| 124 | +905x | +
+ ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])+ |
+ ||
| 125 | +905x | +
+ empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5) |
||
| 31 | +126 |
- }+ } |
||
| 32 | +127 | |||
| 33 | -+ | |||
| 128 | +1147x |
- #' Conversion of a vector to a factor+ if (gg_helper) {
|
||
| 34 | -+ | |||
| 129 | +4x |
- #'+ ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]]) |
||
| 35 | +130 |
- #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user+ } |
||
| 36 | +131 |
- #' can decide whether they prefer converting to factor manually (e.g. for full control of+ |
||
| 37 | -+ | |||
| 132 | +1147x |
- #' factor levels).+ attr(ci, "conf_level") <- empir_conf_level |
||
| 38 | +133 |
- #'+ |
||
| 39 | -+ | |||
| 134 | +1147x |
- #' @param x (`vector`)\cr object to convert.+ return(ci) |
||
| 40 | +135 |
- #' @param x_name (`string`)\cr name of `x`.+ } |
||
| 41 | +136 |
- #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector.+ |
||
| 42 | +137 |
- #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages.+ #' p-Value of the mean |
||
| 43 | +138 |
#' |
||
| 44 | +139 |
- #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 45 | +140 |
#' |
||
| 46 | +141 |
- #' @keywords internal+ #' Convenient function for calculating the two-sided p-value of the mean. |
||
| 47 | +142 |
- as_factor_keep_attributes <- function(x,+ #' |
||
| 48 | +143 |
- x_name = deparse(substitute(x)),+ #' @inheritParams argument_convention |
||
| 49 | +144 |
- na_level = "<Missing>",+ #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean. |
||
| 50 | +145 |
- verbose = TRUE) {
+ #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis. |
||
| 51 | -205x | +|||
| 146 | +
- checkmate::assert_atomic(x)+ #' |
|||
| 52 | -205x | +|||
| 147 | +
- checkmate::assert_string(x_name)+ #' @return A p-value. |
|||
| 53 | -205x | +|||
| 148 | +
- checkmate::assert_string(na_level)+ #' |
|||
| 54 | -205x | +|||
| 149 | +
- checkmate::assert_flag(verbose)+ #' @examples |
|||
| 55 | -205x | +|||
| 150 | +
- if (is.factor(x)) {
+ #' stat_mean_pval(sample(10)) |
|||
| 56 | -186x | +|||
| 151 | +
- return(x)+ #' |
|||
| 57 | +152 |
- }+ #' stat_mean_pval(rnorm(10), test_mean = 0.5)+ |
+ ||
| 153 | ++ |
+ #'+ |
+ ||
| 154 | ++ |
+ #' @export+ |
+ ||
| 155 | ++ |
+ stat_mean_pval <- function(x,+ |
+ ||
| 156 | ++ |
+ na.rm = TRUE, # nolint+ |
+ ||
| 157 | ++ |
+ n_min = 2,+ |
+ ||
| 158 | ++ |
+ test_mean = 0) {
|
||
| 58 | -19x | +159 | +1147x |
- x_class <- class(x)[1]+ if (na.rm) {
|
| 59 | -19x | +160 | +9x |
- if (verbose) {
+ x <- stats::na.omit(x)+ |
+
| 161 | ++ |
+ } |
||
| 60 | -15x | +162 | +1147x |
- warning(paste(+ n <- length(x)+ |
+
| 163 | ++ | + | ||
| 61 | -15x | +164 | +1147x |
- "automatically converting", x_class, "variable", x_name,+ x_mean <- mean(x) |
| 62 | -15x | +165 | +1147x |
- "to factor, better manually convert to factor to avoid failures"+ x_sd <- stats::sd(x) |
| 63 | +166 |
- ))+ + |
+ ||
| 167 | +1147x | +
+ if (n < n_min) {
+ |
+ ||
| 168 | +140x | +
+ pv <- c(p_value = NA_real_) |
||
| 64 | +169 |
- }+ } else {
|
||
| 65 | -19x | +170 | +1007x |
- if (identical(length(x), 0L)) {
+ x_se <- stats::sd(x) / sqrt(n) |
| 66 | -1x | +171 | +1007x |
- warning(paste(+ ttest <- (x_mean - test_mean) / x_se |
| 67 | -1x | +172 | +1007x |
- x_name, "has length 0, this can lead to tabulation failures, better convert to factor"+ pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1)) |
| 68 | +173 |
- ))+ } |
||
| 69 | +174 |
- }+ |
||
| 70 | -19x | +175 | +1147x |
- if (is.character(x)) {
+ return(pv) |
| 71 | -19x | +|||
| 176 | +
- x_no_na <- explicit_na(sas_na(x), label = na_level)+ } |
|||
| 72 | -19x | +|||
| 177 | +
- if (any(na_level %in% x_no_na)) {
+
|
|||
| 73 | -3x | +|||
| 178 | +
- do.call(+ #' Proportion difference and confidence interval |
|||
| 74 | -3x | +|||
| 179 | +
- structure,+ #' |
|||
| 75 | -3x | +|||
| 180 | +
- c(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 76 | -3x | +|||
| 181 | +
- list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),+ #' |
|||
| 77 | -3x | +|||
| 182 | +
- attributes(x)+ #' Function for calculating the proportion (or risk) difference and confidence interval between arm |
|||
| 78 | +183 |
- )+ #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence |
||
| 79 | +184 |
- )+ #' in arm Y from cumulative incidence in arm X. |
||
| 80 | +185 |
- } else {
+ #' |
||
| 81 | -16x | +|||
| 186 | +
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ #' @inheritParams argument_convention |
|||
| 82 | +187 |
- }+ #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group). |
||
| 83 | +188 |
- } else {
+ #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`. |
||
| 84 | -! | +|||
| 189 | +
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ #' @param N_x (`numeric(1)`)\cr total number of records in arm X. |
|||
| 85 | +190 |
- }+ #' @param N_y (`numeric(1)`)\cr total number of records in arm Y. |
||
| 86 | +191 |
- }+ #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in |
||
| 87 | +192 |
-
+ #' `x` and `y`. Must be of equal length to `x` and `y`. |
||
| 88 | +193 |
- #' Labels for bins in percent+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
||
| 89 | +194 |
#' |
||
| 90 | +195 |
- #' This creates labels for quantile based bins in percent. This assumes the right-closed+ #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and |
||
| 91 | +196 |
- #' intervals as produced by [cut_quantile_bins()].+ #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound. |
||
| 92 | +197 |
#' |
||
| 93 | +198 |
- #' @param probs (`numeric`)\cr the probabilities identifying the quantiles.+ #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] |
||
| 94 | +199 |
- #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where+ #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing |
||
| 95 | +200 |
- #' the boundaries 0 and 1 must not be included.+ #' proportion (risk) difference to an `rtables` layout. |
||
| 96 | +201 |
- #' @param digits (`integer(1)`)\cr number of decimal places to round the percent numbers.+ #' |
||
| 97 | +202 | ++ |
+ #' @examples+ |
+ |
| 203 | ++ |
+ #' stat_propdiff_ci(+ |
+ ||
| 204 | ++ |
+ #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9+ |
+ ||
| 205 | ++ |
+ #' )+ |
+ ||
| 206 |
#' |
|||
| 98 | +207 |
- #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.+ #' stat_propdiff_ci( |
||
| 99 | +208 | ++ |
+ #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE+ |
+ |
| 209 | ++ |
+ #' )+ |
+ ||
| 210 |
#' |
|||
| 100 | +211 |
- #' @keywords internal+ #' @export |
||
| 101 | +212 |
- bins_percent_labels <- function(probs,+ stat_propdiff_ci <- function(x, |
||
| 102 | +213 |
- digits = 0) {
+ y, |
||
| 103 | -3x | +|||
| 214 | +
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ N_x, # nolint |
|||
| 104 | -3x | +|||
| 215 | +
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ N_y, # nolint |
|||
| 105 | -10x | +|||
| 216 | +
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ list_names = NULL, |
|||
| 106 | -10x | +|||
| 217 | +
- percent <- round(probs * 100, digits = digits)+ conf_level = 0.95,+ |
+ |||
| 218 | ++ |
+ pct = TRUE) {
|
||
| 107 | -10x | +219 | +51x |
- left <- paste0(utils::head(percent, -1), "%")+ checkmate::assert_list(x, types = "numeric") |
| 108 | -10x | +220 | +51x |
- right <- paste0(utils::tail(percent, -1), "%")+ checkmate::assert_list(y, types = "numeric", len = length(x)) |
| 109 | -10x | +221 | +51x |
- without_left_bracket <- paste0(left, ",", right, "]")+ checkmate::assert_character(list_names, len = length(x), null.ok = TRUE) |
| 110 | -10x | +222 | +51x |
- with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
+ rd_list <- lapply(seq_along(x), function(i) {
|
| 111 | -10x | +223 | +134x |
- if (length(without_left_bracket) > 1) {
+ p_x <- x[[i]] / N_x |
| 112 | -7x | +224 | +134x |
- with_left_bracket <- c(+ p_y <- y[[i]] / N_y |
| 113 | -7x | +225 | +134x |
- with_left_bracket,+ rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) * |
| 114 | -7x | +226 | +134x |
- paste0("(", utils::tail(without_left_bracket, -1))
+ sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y) |
| 115 | -+ | |||
| 227 | +134x |
- )+ c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1) |
||
| 116 | +228 |
- }+ }) |
||
| 117 | -10x | +229 | +51x |
- with_left_bracket+ names(rd_list) <- list_names |
| 118 | -+ | |||
| 230 | +51x |
- }+ rd_list |
||
| 119 | +231 |
-
+ } |
| 120 | +1 |
- #' Cut numeric vector into empirical quantile bins+ #' Count number of patients |
||
| 121 | +2 |
#' |
||
| 122 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 123 | +4 |
#' |
||
| 124 | +5 |
- #' This cuts a numeric vector into sample quantile bins.+ #' The analyze function [analyze_num_patients()] creates a layout element to count total numbers of unique or |
||
| 125 | +6 |
- #'+ #' non-unique patients. The primary analysis variable `vars` is used to uniquely identify patients. |
||
| 126 | +7 |
- #' @inheritParams bins_percent_labels+ #' |
||
| 127 | +8 |
- #' @param x (`numeric`)\cr the continuous variable values which should be cut into+ #' The `count_by` variable can be used to identify non-unique patients such that the number of patients with a unique |
||
| 128 | +9 |
- #' quantile bins. This may contain `NA` values, which are then+ #' combination of values in `vars` and `count_by` will be returned instead as the `nonunique` statistic. The `required` |
||
| 129 | +10 |
- #' not used for the quantile calculations, but included in the return vector.+ #' variable can be used to specify a variable required to be non-missing for the record to be included in the counts. |
||
| 130 | +11 |
- #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`+ #' |
||
| 131 | +12 |
- #' probabilities in `probs`, then this must be `n + 1` long.+ #' The summarize function [summarize_num_patients()] performs the same function as [analyze_num_patients()] except it |
||
| 132 | +13 |
- #' @param type (`integer(1)`)\cr type of quantiles to use, see [stats::quantile()] for details.+ #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of |
||
| 133 | +14 |
- #' @param ordered (`flag`)\cr should the result be an ordered factor.+ #' the latest row split or the root of the table if no row splits have occurred. |
||
| 134 | +15 |
#' |
||
| 135 | +16 |
- #' @return A `factor` variable with appropriately-labeled bins as levels.+ #' @inheritParams argument_convention |
||
| 136 | +17 |
- #'+ #' @param required (`character` or `NULL`)\cr name of a variable that is required to be non-missing. |
||
| 137 | +18 |
- #' @note Intervals are closed on the right side. That is, the first bin is the interval+ #' @param count_by (`character` or `NULL`)\cr name of a variable to be combined with `vars` when counting |
||
| 138 | +19 |
- #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc.,+ #' `nonunique` records. |
||
| 139 | +20 |
- #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile.+ #' @param unique_count_suffix (`flag`)\cr whether the `"(n)"` suffix should be added to `unique_count` labels. |
||
| 140 | +21 |
- #'+ #' Defaults to `TRUE`. |
||
| 141 | +22 |
- #' @examples+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 142 | +23 |
- #' # Default is to cut into quartile bins.+ #' |
||
| 143 | +24 |
- #' cut_quantile_bins(cars$speed)+ #' Options are: ``r shQuote(get_stats("summarize_num_patients"))``
|
||
| 144 | +25 |
#' |
||
| 145 | +26 |
- #' # Use custom quantiles.+ #' @name summarize_num_patients |
||
| 146 | +27 |
- #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))+ #' @order 1 |
||
| 147 | +28 |
- #'+ NULL |
||
| 148 | +29 |
- #' # Use custom labels.+ |
||
| 149 | +30 |
- #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
+ #' @describeIn summarize_num_patients Statistics function which counts the number of |
||
| 150 | +31 |
- #'+ #' unique patients, the corresponding percentage taken with respect to the |
||
| 151 | +32 |
- #' # NAs are preserved in result factor.+ #' total number of patients, and the number of non-unique patients. |
||
| 152 | +33 |
- #' ozone_binned <- cut_quantile_bins(airquality$Ozone)+ #' |
||
| 153 | +34 |
- #' which(is.na(ozone_binned))+ #' @param x (`character` or `factor`)\cr vector of patient IDs. |
||
| 154 | +35 |
- #' # So you might want to make these explicit.+ #' |
||
| 155 | +36 |
- #' explicit_na(ozone_binned)+ #' @return |
||
| 156 | +37 |
- #'+ #' * `s_num_patients()` returns a named `list` of 3 statistics: |
||
| 157 | +38 |
- #' @export+ #' * `unique`: Vector of counts and percentages. |
||
| 158 | +39 |
- cut_quantile_bins <- function(x,+ #' * `nonunique`: Vector of counts. |
||
| 159 | +40 |
- probs = c(0.25, 0.5, 0.75),+ #' * `unique_count`: Counts. |
||
| 160 | +41 |
- labels = NULL,+ #' |
||
| 161 | +42 |
- type = 7,+ #' @examples |
||
| 162 | +43 |
- ordered = TRUE) {
- |
- ||
| 163 | -8x | -
- checkmate::assert_flag(ordered)- |
- ||
| 164 | -8x | -
- checkmate::assert_numeric(x)+ #' # Use the statistics function to count number of unique and nonunique patients. |
||
| 165 | -7x | +|||
| 44 | +
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L) |
|||
| 166 | -7x | +|||
| 45 | +
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ #' s_num_patients( |
|||
| 167 | -8x | +|||
| 46 | +
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ #' x = as.character(c(1, 1, 1, 2, 4, NA)), |
|||
| 168 | -7x | +|||
| 47 | +
- if (is.null(labels)) labels <- bins_percent_labels(probs)+ #' labelstr = "", |
|||
| 169 | -8x | +|||
| 48 | +
- checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE)+ #' .N_col = 6L, |
|||
| 170 | +49 |
-
+ #' count_by = c(1, 1, 2, 1, 1, 1) |
||
| 171 | -8x | +|||
| 50 | +
- if (all(is.na(x))) {
+ #' ) |
|||
| 172 | +51 |
- # Early return if there are only NAs in input.+ #' |
||
| 173 | -1x | +|||
| 52 | +
- return(factor(x, ordered = ordered, levels = labels))+ #' @export |
|||
| 174 | +53 |
- }+ s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
|
||
| 175 | +54 | |||
| 176 | -7x | -
- quantiles <- stats::quantile(- |
- ||
| 177 | -7x | +55 | +146x |
- x,+ checkmate::assert_string(labelstr) |
| 178 | -7x | +56 | +146x |
- probs = probs,+ checkmate::assert_count(.N_col) |
| 179 | -7x | +57 | +146x |
- type = type,+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
| 180 | -7x | +58 | +146x |
- na.rm = TRUE+ checkmate::assert_flag(unique_count_suffix) |
| 181 | +59 |
- )+ |
||
| 182 | -+ | |||
| 60 | +146x |
-
+ count1 <- n_available(unique(x)) |
||
| 183 | -7x | +61 | +146x |
- checkmate::assert_numeric(quantiles, unique = TRUE)+ count2 <- n_available(x) |
| 184 | +62 | |||
| 185 | -6x | +63 | +146x |
- cut(+ if (!is.null(count_by)) {
|
| 186 | -6x | +64 | +16x |
- x,+ checkmate::assert_vector(count_by, len = length(x)) |
| 187 | -6x | +65 | +16x |
- breaks = quantiles,+ count2 <- n_available(unique(interaction(x, count_by)))+ |
+
| 66 | ++ |
+ }+ |
+ ||
| 67 | ++ | + | ||
| 188 | -6x | +68 | +146x |
- labels = labels,+ out <- list( |
| 189 | -6x | +69 | +146x |
- ordered_result = ordered,+ unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr), |
| 190 | -6x | +70 | +146x |
- include.lowest = TRUE,+ nonunique = formatters::with_label(count2, labelstr), |
| 191 | -6x | +71 | +146x |
- right = TRUE+ unique_count = formatters::with_label( |
| 192 | -+ | |||
| 72 | +146x |
- )+ count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr) |
||
| 193 | +73 |
- }+ ) |
||
| 194 | +74 |
-
+ ) |
||
| 195 | +75 |
- #' Discard specified levels of a factor+ |
||
| 196 | -+ | |||
| 76 | +146x |
- #'+ out |
||
| 197 | +77 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 198 | +78 |
- #'+ |
||
| 199 | +79 |
- #' This discards the observations as well as the levels specified from a factor.+ #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients |
||
| 200 | +80 |
- #'+ #' in a column (variable), the corresponding percentage taken with respect to the total number of |
||
| 201 | +81 |
- #' @param x (`factor`)\cr the original factor.+ #' patients, and the number of non-unique patients in the column. |
||
| 202 | +82 |
- #' @param discard (`character`)\cr levels to discard.+ #' |
||
| 203 | +83 |
- #'+ #' @return |
||
| 204 | +84 |
- #' @return A modified `factor` with observations as well as levels from `discard` dropped.+ #' * `s_num_patients_content()` returns the same values as `s_num_patients()`. |
||
| 205 | +85 |
#' |
||
| 206 | +86 |
#' @examples |
||
| 207 | +87 |
- #' fct_discard(factor(c("a", "b", "c")), "c")
+ #' # Count number of unique and non-unique patients. |
||
| 208 | +88 |
#' |
||
| 209 | +89 |
- #' @export+ #' df <- data.frame( |
||
| 210 | +90 |
- fct_discard <- function(x, discard) {
- |
- ||
| 211 | -319x | -
- checkmate::assert_factor(x)+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
||
| 212 | -319x | +|||
| 91 | +
- checkmate::assert_character(discard, any.missing = FALSE)+ #' EVENT = as.character(c(10, 15, 10, 17, 8)) |
|||
| 213 | -319x | +|||
| 92 | +
- new_obs <- x[!(x %in% discard)]+ #' ) |
|||
| 214 | -319x | +|||
| 93 | +
- new_levels <- setdiff(levels(x), discard)+ #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID") |
|||
| 215 | -319x | +|||
| 94 | +
- factor(new_obs, levels = new_levels)+ #' |
|||
| 216 | +95 |
- }+ #' df_by_event <- data.frame( |
||
| 217 | +96 |
-
+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
||
| 218 | +97 |
- #' Insertion of explicit missing values in a factor+ #' EVENT = c(10, 15, 10, 17, 8) |
||
| 219 | +98 |
- #'+ #' ) |
||
| 220 | +99 |
- #' @description `r lifecycle::badge("stable")`
+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT") |
||
| 221 | +100 |
#' |
||
| 222 | +101 |
- #' This inserts explicit missing values in a factor based on a condition. Additionally,+ #' @export |
||
| 223 | +102 |
- #' existing `NA` values will be explicitly converted to given `na_level`.+ s_num_patients_content <- function(df, |
||
| 224 | +103 |
- #'+ labelstr = "", |
||
| 225 | +104 |
- #' @param x (`factor`)\cr the original factor.+ .N_col, # nolint |
||
| 226 | +105 |
- #' @param condition (`logical`)\cr positions at which to insert missing values.+ .var, |
||
| 227 | +106 |
- #' @param na_level (`string`)\cr which level to use for missing values.+ required = NULL, |
||
| 228 | +107 |
- #'+ count_by = NULL, |
||
| 229 | +108 |
- #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`.+ unique_count_suffix = TRUE) {
|
||
| 230 | -+ | |||
| 109 | +56x |
- #'+ checkmate::assert_string(.var) |
||
| 231 | -+ | |||
| 110 | +56x |
- #' @seealso [forcats::fct_na_value_to_level()] which is used internally.+ checkmate::assert_data_frame(df) |
||
| 232 | -+ | |||
| 111 | +56x |
- #'+ if (is.null(count_by)) {
|
||
| 233 | -+ | |||
| 112 | +53x |
- #' @examples+ assert_df_with_variables(df, list(id = .var)) |
||
| 234 | +113 |
- #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
+ } else {
|
||
| 235 | -+ | |||
| 114 | +3x |
- #'+ assert_df_with_variables(df, list(id = .var, count_by = count_by)) |
||
| 236 | +115 |
- #' @export+ } |
||
| 237 | -+ | |||
| 116 | +56x |
- fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
+ if (!is.null(required)) {
|
||
| 238 | -1x | +|||
| 117 | +! |
- checkmate::assert_factor(x, len = length(condition))+ checkmate::assert_string(required) |
||
| 239 | -1x | +|||
| 118 | +! |
- checkmate::assert_logical(condition)+ assert_df_with_variables(df, list(required = required)) |
||
| 240 | -1x | +|||
| 119 | +! |
- x[condition] <- NA+ df <- df[!is.na(df[[required]]), , drop = FALSE] |
||
| 241 | -1x | +|||
| 120 | +
- x <- forcats::fct_na_value_to_level(x, level = na_level)+ }+ |
+ |||
| 121 | ++ | + | ||
| 242 | -1x | +122 | +56x |
- forcats::fct_drop(x, only = na_level)+ x <- df[[.var]] |
| 243 | -+ | |||
| 123 | +56x |
- }+ y <- if (is.null(count_by)) NULL else df[[count_by]] |
||
| 244 | +124 | |||
| 245 | -+ | |||
| 125 | +56x |
- #' Collapse factor levels and keep only those new group levels+ s_num_patients( |
||
| 246 | -+ | |||
| 126 | +56x |
- #'+ x = x, |
||
| 247 | -+ | |||
| 127 | +56x |
- #' @description `r lifecycle::badge("stable")`
+ labelstr = labelstr, |
||
| 248 | -+ | |||
| 128 | +56x |
- #'+ .N_col = .N_col, |
||
| 249 | -+ | |||
| 129 | +56x |
- #' This collapses levels and only keeps those new group levels, in the order provided.+ count_by = y,+ |
+ ||
| 130 | +56x | +
+ unique_count_suffix = unique_count_suffix |
||
| 250 | +131 |
- #' The returned factor has levels in the order given, with the possible missing level last (this will+ ) |
||
| 251 | +132 |
- #' only be included if there are missing values).+ } |
||
| 252 | +133 |
- #'+ |
||
| 253 | +134 |
- #' @param .f (`factor` or `character`)\cr original vector.+ c_num_patients <- make_afun( |
||
| 254 | +135 |
- #' @param ... (named `character`)\cr levels in each vector provided will be collapsed into+ s_num_patients_content, |
||
| 255 | +136 |
- #' the new level given by the respective name.+ .stats = c("unique", "nonunique", "unique_count"),
|
||
| 256 | +137 |
- #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the+ .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx") |
||
| 257 | +138 |
- #' new factor. Note that this level must not be contained in the new levels specified in `...`.+ ) |
||
| 258 | +139 |
- #'+ |
||
| 259 | +140 |
- #' @return A modified `factor` with collapsed levels. Values and levels which are not included+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 260 | +141 |
- #' in the given `character` vector input will be set to the missing level `.na_level`.+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 261 | +142 |
#' |
||
| 262 | +143 |
- #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed,+ #' @return |
||
| 263 | +144 |
- #' [explicit_na()] can be called separately on the result.+ #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 264 | +145 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 265 | +146 |
- #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 266 | +147 |
#' |
||
| 267 | +148 |
#' @examples |
||
| 268 | +149 |
- #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
+ #' # summarize_num_patients |
||
| 269 | +150 |
- #'+ #' tbl <- basic_table() %>% |
||
| 270 | +151 |
- #' @export+ #' split_cols_by("ARM") %>%
|
||
| 271 | +152 |
- fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
+ #' split_rows_by("SEX") %>%
|
||
| 272 | -4x | +|||
| 153 | +
- new_lvls <- names(list(...))+ #' summarize_num_patients("USUBJID", .stats = "unique_count") %>%
|
|||
| 273 | -4x | +|||
| 154 | +
- if (checkmate::test_subset(.na_level, new_lvls)) {
+ #' build_table(df) |
|||
| 274 | -1x | +|||
| 155 | +
- stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
+ #' |
|||
| 275 | +156 |
- }+ #' tbl |
||
| 276 | -3x | +|||
| 157 | +
- x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ #' |
|||
| 277 | -3x | +|||
| 158 | +
- do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))+ #' @export |
|||
| 278 | +159 |
- }+ #' @order 3 |
||
| 279 | +160 |
-
+ summarize_num_patients <- function(lyt, |
||
| 280 | +161 |
- #' Ungroup non-numeric statistics+ var, |
||
| 281 | +162 |
- #'+ required = NULL, |
||
| 282 | +163 |
- #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`.+ count_by = NULL, |
||
| 283 | +164 |
- #'+ unique_count_suffix = TRUE, |
||
| 284 | +165 |
- #' @inheritParams argument_convention+ na_str = default_na_str(), |
||
| 285 | +166 |
- #' @param x (named `list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup.+ .stats = NULL, |
||
| 286 | +167 |
- #'+ .formats = NULL, |
||
| 287 | +168 |
- #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`.+ .labels = c( |
||
| 288 | +169 |
- #'+ unique = "Number of patients with at least one event", |
||
| 289 | +170 |
- #' @seealso [a_summary()] which uses this function internally.+ nonunique = "Number of events" |
||
| 290 | +171 |
- #'+ ), |
||
| 291 | +172 |
- #' @keywords internal+ .indent_mods = 0L, |
||
| 292 | +173 |
- ungroup_stats <- function(x,+ riskdiff = FALSE, |
||
| 293 | +174 |
- .formats,+ ...) {
|
||
| 294 | -+ | |||
| 175 | +16x |
- .labels,+ checkmate::assert_flag(riskdiff) |
||
| 295 | +176 |
- .indent_mods) {
+
|
||
| 296 | -401x | +177 | +5x |
- checkmate::assert_list(x)+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
| 297 | -401x | +178 | +8x |
- empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
| 298 | -401x | +|||
| 179 | +
- empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0+ |
|||
| 299 | -401x | +180 | +16x |
- x <- unlist(x, recursive = FALSE)+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...) |
| 300 | +181 | |||
| 301 | -+ | |||
| 182 | +16x |
- # If p-value is empty it is removed by unlist and needs to be re-added+ cfun <- make_afun( |
||
| 302 | -! | +|||
| 183 | +16x |
- if (empty_pval) x[["pval"]] <- character()+ c_num_patients, |
||
| 303 | -3x | +184 | +16x |
- if (empty_pval_counts) x[["pval_counts"]] <- character()+ .stats = .stats, |
| 304 | -401x | +185 | +16x |
- .stats <- names(x)+ .formats = .formats,+ |
+
| 186 | +16x | +
+ .labels = .labels |
||
| 305 | +187 |
-
+ ) |
||
| 306 | +188 |
- # Ungroup stats+ |
||
| 307 | -401x | +189 | +16x |
- .formats <- lapply(.stats, function(x) {
+ extra_args <- if (isFALSE(riskdiff)) {
|
| 308 | -2981x | +190 | +14x |
- .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ s_args |
| 309 | +191 |
- })+ } else {
|
||
| 310 | -401x | +192 | +2x |
- .indent_mods <- sapply(.stats, function(x) {
+ list( |
| 311 | -2981x | +193 | +2x |
- .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ afun = list("s_num_patients_content" = cfun),
|
| 312 | -+ | |||
| 194 | +2x |
- })+ .stats = .stats, |
||
| 313 | -401x | +195 | +2x |
- .labels <- sapply(.stats, function(x) {
+ .indent_mods = .indent_mods, |
| 314 | -2912x | +196 | +2x |
- if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
+ s_args = s_args |
| 315 | +197 |
- })+ ) |
||
| 316 | +198 | ++ |
+ }+ |
+ |
| 199 | ||||
| 317 | -401x | +200 | +16x |
- list(+ summarize_row_groups( |
| 318 | -401x | +201 | +16x |
- x = x,+ lyt = lyt, |
| 319 | -401x | +202 | +16x |
- .formats = .formats,+ var = var, |
| 320 | -401x | +203 | +16x |
- .labels = .labels,+ cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff), |
| 321 | -401x | +204 | +16x |
- .indent_mods = .indent_mods+ na_str = na_str,+ |
+
| 205 | +16x | +
+ extra_args = extra_args,+ |
+ ||
| 206 | +16x | +
+ indent_mod = .indent_mods |
||
| 322 | +207 |
) |
||
| 323 | +208 |
} |
| 1 | +209 |
- #' Add titles, footnotes, page Number, and a bounding box to a grid grob+ |
|
| 2 | +210 |
- #'+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
|
| 3 | +211 |
- #' @description `r lifecycle::badge("stable")`
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 4 | +212 |
#' |
|
| 5 | +213 |
- #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots)+ #' @return |
|
| 6 | +214 |
- #' with title, footnote, and page numbers.+ #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions, |
|
| 7 | +215 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 8 | +216 |
- #' @inheritParams grid::grob+ #' the statistics from `s_num_patients_content()` to the table layout. |
|
| 9 | +217 |
- #' @param grob (`grob`)\cr a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown.+ #' |
|
| 10 | +218 |
- #' @param titles (`character`)\cr titles given as a vector of strings that are each separated by a newline and wrapped+ #' @details In general, functions that starts with `analyze*` are expected to |
|
| 11 | +219 |
- #' according to the page width.+ #' work like [rtables::analyze()], while functions that starts with `summarize*` |
|
| 12 | +220 |
- #' @param footnotes (`character`)\cr footnotes. Uses the same formatting rules as `titles`.+ #' are based upon [rtables::summarize_row_groups()]. The latter provides a |
|
| 13 | +221 |
- #' @param page (`string` or `NULL`)\cr page numeration. If `NULL` then no page number is displayed.+ #' value for each dividing split in the row and column space, but, being it |
|
| 14 | +222 |
- #' @param width_titles (`grid::unit`)\cr width of titles. Usually defined as all the available space+ #' bound to the fundamental splits, it is repeated by design in every page |
|
| 15 | +223 |
- #' `grid::unit(1, "npc")`, it is affected by the parameter `outer_margins`. Right margins (`outer_margins[4]`)+ #' when pagination is involved. |
|
| 16 | +224 |
- #' need to be subtracted to the allowed width.+ #' |
|
| 17 | +225 |
- #' @param width_footnotes (`grid::unit`)\cr width of footnotes. Same default and margin correction as `width_titles`.+ #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows. |
|
| 18 | +226 |
- #' @param border (`flag`)\cr whether a border should be drawn around the plot or not.+ #' |
|
| 19 | +227 |
- #' @param padding (`grid::unit`)\cr padding. A unit object of length 4. Innermost margin between the plot (`grob`)+ #' @examples |
|
| 20 | +228 |
- #' and, possibly, the border of the plot. Usually expressed in 4 identical values (usually `"lines"`). It defaults+ #' df <- data.frame( |
|
| 21 | +229 |
- #' to `grid::unit(rep(1, 4), "lines")`.+ #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)), |
|
| 22 | +230 |
- #' @param margins (`grid::unit`)\cr margins. A unit object of length 4. Margins between the plot and the other+ #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
|
|
| 23 | +231 |
- #' elements in the list (e.g. titles, plot, and footers). This is usually expressed in 4 `"lines"`, where the+ #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17), |
|
| 24 | +232 |
- #' lateral ones are 0s, while top and bottom are 1s. It defaults to `grid::unit(c(1, 0, 1, 0), "lines")`.+ #' SEX = c("M", "M", "M", "F", "F", "F", "M", "F", "M")
|
|
| 25 | +233 |
- #' @param outer_margins (`grid::unit`)\cr outer margins. A unit object of length 4. It defines the general margin of+ #' ) |
|
| 26 | +234 |
- #' the plot, considering also decorations like titles, footnotes, and page numbers. It defaults to+ #' |
|
| 27 | +235 |
- #' `grid::unit(c(2, 1.5, 3, 1.5), "cm")`.+ #' # analyze_num_patients |
|
| 28 | +236 |
- #' @param gp_titles (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.+ #' tbl <- basic_table() %>% |
|
| 29 | +237 |
- #' @param gp_footnotes (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.+ #' split_cols_by("ARM") %>%
|
|
| 30 | +238 |
- #'+ #' add_colcounts() %>% |
|
| 31 | +239 |
- #' @return A grid grob (`gTree`).+ #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
|
|
| 32 | +240 |
- #'+ #' build_table(df) |
|
| 33 | +241 |
- #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually.+ #' |
|
| 34 | +242 |
- #'+ #' tbl |
|
| 35 | +243 |
- #' @examples+ #' |
|
| 36 | +244 |
- #' library(grid)+ #' @export |
|
| 37 | +245 |
- #'+ #' @order 2 |
|
| 38 | +246 |
- #' titles <- c(+ analyze_num_patients <- function(lyt, |
|
| 39 | +247 |
- #' "Edgar Anderson's Iris Data",+ vars, |
|
| 40 | +248 |
- #' paste(+ required = NULL, |
|
| 41 | +249 |
- #' "This famous (Fisher's or Anderson's) iris data set gives the measurements",+ count_by = NULL, |
|
| 42 | +250 |
- #' "in centimeters of the variables sepal length and width and petal length",+ unique_count_suffix = TRUE, |
|
| 43 | +251 |
- #' "and width, respectively, for 50 flowers from each of 3 species of iris."+ na_str = default_na_str(), |
|
| 44 | +252 |
- #' )+ nested = TRUE, |
|
| 45 | +253 |
- #' )+ .stats = NULL, |
|
| 46 | +254 |
- #'+ .formats = NULL, |
|
| 47 | +255 |
- #' footnotes <- c(+ .labels = c( |
|
| 48 | +256 |
- #' "The species are Iris setosa, versicolor, and virginica.",+ unique = "Number of patients with at least one event", |
|
| 49 | +257 |
- #' paste(+ nonunique = "Number of events" |
|
| 50 | +258 |
- #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",+ ), |
|
| 51 | +259 |
- #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."+ show_labels = c("default", "visible", "hidden"),
|
|
| 52 | +260 |
- #' )+ .indent_mods = 0L, |
|
| 53 | +261 |
- #' )+ riskdiff = FALSE, |
|
| 54 | +262 |
- #'+ ...) {
|
|
| 55 | -+ | ||
| 263 | +4x |
- #' ## empty plot+ checkmate::assert_flag(riskdiff) |
|
| 56 | +264 |
- #' grid.newpage()+ |
|
| 57 | -+ | ||
| 265 | +1x |
- #'+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
|
| 58 | -+ | ||
| 266 | +! |
- #' grid.draw(+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
|
| 59 | +267 |
- #' decorate_grob(+ |
|
| 60 | -+ | ||
| 268 | +4x |
- #' NULL,+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...) |
|
| 61 | +269 |
- #' titles = titles,+ |
|
| 62 | -+ | ||
| 270 | +4x |
- #' footnotes = footnotes,+ afun <- make_afun( |
|
| 63 | -+ | ||
| 271 | +4x |
- #' page = "Page 4 of 10"+ c_num_patients, |
|
| 64 | -+ | ||
| 272 | +4x |
- #' )+ .stats = .stats, |
|
| 65 | -+ | ||
| 273 | +4x |
- #' )+ .formats = .formats, |
|
| 66 | -+ | ||
| 274 | +4x |
- #'+ .labels = .labels |
|
| 67 | +275 |
- #' # grid+ ) |
|
| 68 | +276 |
- #' p <- gTree(+ |
|
| 69 | -+ | ||
| 277 | +4x |
- #' children = gList(+ extra_args <- if (isFALSE(riskdiff)) {
|
|
| 70 | -+ | ||
| 278 | +2x |
- #' rectGrob(),+ s_args |
|
| 71 | +279 |
- #' xaxisGrob(),+ } else {
|
|
| 72 | -+ | ||
| 280 | +2x |
- #' yaxisGrob(),+ list( |
|
| 73 | -+ | ||
| 281 | +2x |
- #' textGrob("Sepal.Length", y = unit(-4, "lines")),
+ afun = list("s_num_patients_content" = afun),
|
|
| 74 | -+ | ||
| 282 | +2x |
- #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
+ .stats = .stats, |
|
| 75 | -+ | ||
| 283 | +2x |
- #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)+ .indent_mods = .indent_mods, |
|
| 76 | -+ | ||
| 284 | +2x |
- #' ),+ s_args = s_args |
|
| 77 | +285 |
- #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))+ ) |
|
| 78 | +286 |
- #' )+ } |
|
| 79 | +287 |
- #' grid.newpage()+ |
|
| 80 | -+ | ||
| 288 | +4x |
- #' grid.draw(p)+ analyze( |
|
| 81 | -+ | ||
| 289 | +4x |
- #'+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
|
| 82 | -+ | ||
| 290 | +4x |
- #' grid.newpage()+ lyt = lyt, |
|
| 83 | -+ | ||
| 291 | +4x |
- #' grid.draw(+ vars = vars, |
|
| 84 | -+ | ||
| 292 | +4x |
- #' decorate_grob(+ na_str = na_str, |
|
| 85 | -+ | ||
| 293 | +4x |
- #' grob = p,+ nested = nested, |
|
| 86 | -+ | ||
| 294 | +4x |
- #' titles = titles,+ extra_args = extra_args, |
|
| 87 | -+ | ||
| 295 | +4x |
- #' footnotes = footnotes,+ show_labels = show_labels,+ |
+ |
| 296 | +4x | +
+ indent_mod = .indent_mods |
|
| 88 | +297 |
- #' page = "Page 6 of 129"+ ) |
|
| 89 | +298 |
- #' )+ } |
| 90 | +1 |
- #' )+ #' Occurrence table pruning |
||
| 91 | +2 |
#' |
||
| 92 | +3 |
- #' ## with ggplot2+ #' @description `r lifecycle::badge("stable")`
|
||
| 93 | +4 |
- #' library(ggplot2)+ #' |
||
| 94 | +5 |
- #'+ #' Family of constructor and condition functions to flexibly prune occurrence tables. |
||
| 95 | +6 |
- #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) ++ #' The condition functions always return whether the row result is higher than the threshold. |
||
| 96 | +7 |
- #' ggplot2::geom_point()+ #' Since they are of class [CombinationFunction()] they can be logically combined with other condition |
||
| 97 | +8 |
- #' p_gg+ #' functions. |
||
| 98 | +9 |
- #' p <- ggplotGrob(p_gg)+ #' |
||
| 99 | +10 |
- #' grid.newpage()+ #' @note Since most table specifications are worded positively, we name our constructor and condition |
||
| 100 | +11 |
- #' grid.draw(+ #' functions positively, too. However, note that the result of [keep_rows()] says what |
||
| 101 | +12 |
- #' decorate_grob(+ #' should be pruned, to conform with the [rtables::prune_table()] interface. |
||
| 102 | +13 |
- #' grob = p,+ #' |
||
| 103 | +14 |
- #' titles = titles,+ #' @examples |
||
| 104 | +15 |
- #' footnotes = footnotes,+ #' \donttest{
|
||
| 105 | +16 |
- #' page = "Page 6 of 129"+ #' tab <- basic_table() %>% |
||
| 106 | +17 |
- #' )+ #' split_cols_by("ARM") %>%
|
||
| 107 | +18 |
- #' )+ #' split_rows_by("RACE") %>%
|
||
| 108 | +19 |
- #'+ #' split_rows_by("STRATA1") %>%
|
||
| 109 | +20 |
- #' ## with lattice+ #' summarize_row_groups() %>% |
||
| 110 | +21 |
- #' library(lattice)+ #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
|
||
| 111 | +22 |
- #'+ #' build_table(DM) |
||
| 112 | +23 |
- #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)+ #' } |
||
| 113 | +24 |
- #' p <- grid.grab()+ #' |
||
| 114 | +25 |
- #' grid.newpage()+ #' @name prune_occurrences |
||
| 115 | +26 |
- #' grid.draw(+ NULL |
||
| 116 | +27 |
- #' decorate_grob(+ |
||
| 117 | +28 |
- #' grob = p,+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
||
| 118 | +29 |
- #' titles = titles,+ #' a row condition function. This removes all analysis rows (`TableRow`) that should be |
||
| 119 | +30 |
- #' footnotes = footnotes,+ #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no |
||
| 120 | +31 |
- #' page = "Page 6 of 129"+ #' children left. |
||
| 121 | +32 |
- #' )+ #' |
||
| 122 | +33 |
- #' )+ #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual |
||
| 123 | +34 |
- #'+ #' analysis rows and flags whether these should be kept in the pruned table. |
||
| 124 | +35 |
- #' # with gridExtra - no borders+ #' |
||
| 125 | +36 |
- #' library(gridExtra)+ #' @return |
||
| 126 | +37 |
- #' grid.newpage()+ #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()] |
||
| 127 | +38 |
- #' grid.draw(+ #' to prune an `rtables` table. |
||
| 128 | +39 |
- #' decorate_grob(+ #' |
||
| 129 | +40 |
- #' tableGrob(+ #' @examples |
||
| 130 | +41 |
- #' head(mtcars)+ #' \donttest{
|
||
| 131 | +42 |
- #' ),+ #' # `keep_rows` |
||
| 132 | +43 |
- #' titles = "title",+ #' is_non_empty <- !CombinationFunction(all_zero_or_na) |
||
| 133 | +44 |
- #' footnotes = "footnote",+ #' prune_table(tab, keep_rows(is_non_empty)) |
||
| 134 | +45 |
- #' border = FALSE+ #' } |
||
| 135 | +46 |
- #' )+ #' |
||
| 136 | +47 |
- #' )+ #' @export |
||
| 137 | +48 |
- #'+ keep_rows <- function(row_condition) {
|
||
| 138 | -+ | |||
| 49 | +6x |
- #' @export+ checkmate::assert_function(row_condition) |
||
| 139 | -+ | |||
| 50 | +6x |
- decorate_grob <- function(grob,+ function(table_tree) {
|
||
| 140 | -+ | |||
| 51 | +2256x |
- titles,+ if (inherits(table_tree, "TableRow")) {
|
||
| 141 | -+ | |||
| 52 | +1872x |
- footnotes,+ return(!row_condition(table_tree)) |
||
| 142 | +53 |
- page = "",+ } |
||
| 143 | -+ | |||
| 54 | +384x |
- width_titles = grid::unit(1, "npc"),+ children <- tree_children(table_tree) |
||
| 144 | -+ | |||
| 55 | +384x |
- width_footnotes = grid::unit(1, "npc"),+ identical(length(children), 0L) |
||
| 145 | +56 |
- border = TRUE,+ } |
||
| 146 | +57 |
- padding = grid::unit(rep(1, 4), "lines"),+ } |
||
| 147 | +58 |
- margins = grid::unit(c(1, 0, 1, 0), "lines"),+ |
||
| 148 | +59 |
- outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
||
| 149 | +60 |
- gp_titles = grid::gpar(),+ #' a condition for the (first) content row in leaf tables. This removes all leaf tables where |
||
| 150 | +61 |
- gp_footnotes = grid::gpar(fontsize = 8),+ #' the first content row does not fulfill the condition. It does not check individual rows. |
||
| 151 | +62 |
- name = NULL,+ #' It then proceeds recursively by removing the sub tree if there are no children left. |
||
| 152 | +63 |
- gp = grid::gpar(),+ #' |
||
| 153 | +64 |
- vp = NULL) {
+ #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual |
||
| 154 | +65 |
- # External margins need to be taken into account when defining the width of titles and footers+ #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table. |
||
| 155 | +66 |
- # because the text is split in advance depending on only the width of the viewport.- |
- ||
| 156 | -9x | -
- if (any(as.numeric(outer_margins) > 0)) {
- |
- ||
| 157 | -9x | -
- width_titles <- width_titles - outer_margins[4]- |
- ||
| 158 | -9x | -
- width_footnotes <- width_footnotes - outer_margins[4]+ #' |
||
| 159 | +67 |
- }+ #' @return |
||
| 160 | +68 |
-
+ #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content |
||
| 161 | -9x | +|||
| 69 | +
- st_titles <- split_text_grob(+ #' row of leaf tables in the table. |
|||
| 162 | -9x | +|||
| 70 | +
- titles,+ #' |
|||
| 163 | -9x | +|||
| 71 | +
- x = 0, y = 1,+ #' @examples |
|||
| 164 | -9x | +|||
| 72 | +
- just = c("left", "top"),
+ #' # `keep_content_rows` |
|||
| 165 | -9x | +|||
| 73 | +
- width = width_titles,+ #' \donttest{
|
|||
| 166 | -9x | +|||
| 74 | +
- vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),+ #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab)) |
|||
| 167 | -9x | +|||
| 75 | +
- gp = gp_titles+ #' prune_table(tab, keep_content_rows(more_than_twenty)) |
|||
| 168 | +76 |
- )+ #' } |
||
| 169 | +77 |
-
+ #' |
||
| 170 | -9x | +|||
| 78 | +
- st_footnotes <- split_text_grob(+ #' @export |
|||
| 171 | -9x | +|||
| 79 | +
- footnotes,+ keep_content_rows <- function(content_row_condition) {
|
|||
| 172 | -9x | +80 | +1x |
- x = 0, y = 1,+ checkmate::assert_function(content_row_condition) |
| 173 | -9x | +81 | +1x |
- just = c("left", "top"),
+ function(table_tree) {
|
| 174 | -9x | +82 | +166x |
- width = width_footnotes,+ if (is_leaf_table(table_tree)) {
|
| 175 | -9x | +83 | +24x |
- vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),+ content_row <- h_content_first_row(table_tree) |
| 176 | -9x | -
- gp = gp_footnotes- |
- ||
| 177 | -+ | 84 | +24x |
- )+ return(!content_row_condition(content_row)) |
| 178 | +85 |
-
+ } |
||
| 179 | -9x | +86 | +142x |
- pg_footnote <- grid::textGrob(+ if (inherits(table_tree, "DataRow")) {
|
| 180 | -9x | +87 | +120x |
- paste("\n", page),
+ return(FALSE) |
| 181 | -9x | +|||
| 88 | +
- x = 1, y = 0,+ } |
|||
| 182 | -9x | +89 | +22x |
- just = c("right", "bottom"),
+ children <- tree_children(table_tree) |
| 183 | -9x | +90 | +22x |
- vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1),+ identical(length(children), 0L) |
| 184 | -9x | +|||
| 91 | +
- gp = gp_footnotes+ } |
|||
| 185 | +92 |
- )+ } |
||
| 186 | +93 | |||
| 187 | +94 |
- # Initial decoration of the grob -> border, paddings, and margins are used here- |
- ||
| 188 | -9x | -
- main_plot <- grid::gTree(- |
- ||
| 189 | -9x | -
- children = grid::gList(- |
- ||
| 190 | -9x | -
- if (border) grid::rectGrob(),- |
- ||
| 191 | -9x | -
- grid::gTree(- |
- ||
| 192 | -9x | -
- children = grid::gList(- |
- ||
| 193 | -9x | -
- grob+ #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns. |
||
| 194 | +95 |
- ),- |
- ||
| 195 | -9x | -
- vp = grid::plotViewport(margins = padding) # innermost margins of the grob plot+ #' |
||
| 196 | +96 |
- )+ #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
||
| 197 | +97 |
- ),- |
- ||
| 198 | -9x | -
- vp = grid::vpStack(- |
- ||
| 199 | -9x | -
- grid::viewport(layout.pos.row = 2, layout.pos.col = 1),+ #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including |
||
| 200 | -9x | +|||
| 98 | +
- grid::plotViewport(margins = margins) # margins around the border plot+ #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices |
|||
| 201 | +99 |
- )+ #' directly instead. |
||
| 202 | +100 |
- )+ #' |
||
| 203 | +101 |
-
+ #' @return |
||
| 204 | -9x | +|||
| 102 | +
- grid::gTree(+ #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column. |
|||
| 205 | -9x | +|||
| 103 | +
- grob = grob,+ #' |
|||
| 206 | -9x | +|||
| 104 | +
- titles = titles,+ #' @examples |
|||
| 207 | -9x | +|||
| 105 | +
- footnotes = footnotes,+ #' \donttest{
|
|||
| 208 | -9x | +|||
| 106 | +
- page = page,+ #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab)) |
|||
| 209 | -9x | +|||
| 107 | +
- width_titles = width_titles,+ #' prune_table(tab, keep_rows(more_than_one)) |
|||
| 210 | -9x | +|||
| 108 | +
- width_footnotes = width_footnotes,+ #' } |
|||
| 211 | -9x | +|||
| 109 | +
- outer_margins = outer_margins,+ #' |
|||
| 212 | -9x | +|||
| 110 | +
- gp_titles = gp_titles,+ #' @export |
|||
| 213 | -9x | +|||
| 111 | +
- gp_footnotes = gp_footnotes,+ has_count_in_cols <- function(atleast, ...) {
|
|||
| 214 | -9x | +112 | +6x |
- children = grid::gList(+ checkmate::assert_count(atleast) |
| 215 | -9x | +113 | +6x |
- grid::gTree(+ CombinationFunction(function(table_row) {
|
| 216 | -9x | +114 | +337x |
- children = grid::gList(+ row_counts <- h_row_counts(table_row, ...) |
| 217 | -9x | +115 | +337x |
- st_titles,+ total_count <- sum(row_counts) |
| 218 | -9x | +116 | +337x |
- main_plot, # main plot with border, padding, and margins+ total_count >= atleast |
| 219 | -9x | +|||
| 117 | +
- st_footnotes,+ }) |
|||
| 220 | -9x | +|||
| 118 | +
- pg_footnote+ } |
|||
| 221 | +119 |
- ),+ |
||
| 222 | -9x | +|||
| 120 | +
- childrenvp = NULL,+ #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in |
|||
| 223 | -9x | +|||
| 121 | +
- name = "titles_grob_footnotes",+ #' the specified columns satisfying a threshold. |
|||
| 224 | -9x | +|||
| 122 | +
- vp = grid::vpStack(+ #' |
|||
| 225 | -9x | +|||
| 123 | +
- grid::plotViewport(margins = outer_margins), # Main external margins+ #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
|||
| 226 | -9x | +|||
| 124 | +
- grid::viewport(+ #' |
|||
| 227 | -9x | +|||
| 125 | +
- layout = grid::grid.layout(+ #' @return |
|||
| 228 | -9x | +|||
| 126 | +
- nrow = 4, ncol = 1,+ #' * `has_count_in_any_col()` returns a condition function that compares the counts in the |
|||
| 229 | -9x | +|||
| 127 | +
- heights = grid::unit.c(+ #' specified columns with the threshold. |
|||
| 230 | -9x | +|||
| 128 | +
- grid::grobHeight(st_titles),+ #' |
|||
| 231 | -9x | +|||
| 129 | +
- grid::unit(1, "null"),+ #' @examples |
|||
| 232 | -9x | +|||
| 130 | +
- grid::grobHeight(st_footnotes),+ #' \donttest{
|
|||
| 233 | -9x | +|||
| 131 | +
- grid::grobHeight(pg_footnote)+ #' # `has_count_in_any_col` |
|||
| 234 | +132 |
- )+ #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab)) |
||
| 235 | +133 |
- )+ #' prune_table(tab, keep_rows(any_more_than_one)) |
||
| 236 | +134 |
- )+ #' } |
||
| 237 | +135 |
- )+ #' |
||
| 238 | +136 |
- )+ #' @export |
||
| 239 | +137 |
- ),+ has_count_in_any_col <- function(atleast, ...) {
|
||
| 240 | -9x | +138 | +3x |
- name = name,+ checkmate::assert_count(atleast) |
| 241 | -9x | +139 | +3x |
- gp = gp,+ CombinationFunction(function(table_row) {
|
| 242 | -9x | +140 | +3x |
- vp = vp,+ row_counts <- h_row_counts(table_row, ...) |
| 243 | -9x | +141 | +3x |
- cl = "decoratedGrob"+ any(row_counts >= atleast) |
| 244 | +142 |
- )+ }) |
||
| 245 | +143 |
} |
||
| 246 | +144 | |||
| 247 | +145 |
- # nocov start+ #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in |
||
| 248 | +146 |
- #' @importFrom grid validDetails+ #' the specified columns. |
||
| 249 | +147 |
- #' @noRd+ #' |
||
| 250 | +148 |
- validDetails.decoratedGrob <- function(x) {
+ #' @return |
||
| 251 | +149 |
- checkmate::assert_character(x$titles)+ #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the |
||
| 252 | +150 |
- checkmate::assert_character(x$footnotes)+ #' specified column, and computes the fraction by dividing by the total column counts. |
||
| 253 | +151 |
-
+ #' |
||
| 254 | +152 |
- if (!is.null(x$grob)) {
+ #' @examples |
||
| 255 | +153 |
- checkmate::assert_true(grid::is.grob(x$grob))+ #' \donttest{
|
||
| 256 | +154 |
- }+ #' # `has_fraction_in_cols` |
||
| 257 | +155 |
- if (length(x$page) == 1) {
+ #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab)) |
||
| 258 | +156 |
- checkmate::assert_character(x$page)+ #' prune_table(tab, keep_rows(more_than_five_percent)) |
||
| 259 | +157 |
- }+ #' } |
||
| 260 | +158 |
- if (!grid::is.unit(x$outer_margins)) {
+ #' |
||
| 261 | +159 |
- checkmate::assert_vector(x$outer_margins, len = 4)+ #' @export |
||
| 262 | +160 |
- }+ has_fraction_in_cols <- function(atleast, ...) {
|
||
| 263 | -+ | |||
| 161 | +4x |
- if (!grid::is.unit(x$margins)) {
+ assert_proportion_value(atleast, include_boundaries = TRUE) |
||
| 264 | -+ | |||
| 162 | +4x |
- checkmate::assert_vector(x$margins, len = 4)+ CombinationFunction(function(table_row) {
|
||
| 265 | -+ | |||
| 163 | +306x |
- }+ row_counts <- h_row_counts(table_row, ...) |
||
| 266 | -+ | |||
| 164 | +306x |
- if (!grid::is.unit(x$padding)) {
+ total_count <- sum(row_counts) |
||
| 267 | -+ | |||
| 165 | +306x |
- checkmate::assert_vector(x$padding, len = 4)+ col_counts <- h_col_counts(table_row, ...) |
||
| 268 | -+ | |||
| 166 | +306x |
- }+ total_n <- sum(col_counts) |
||
| 269 | -+ | |||
| 167 | +306x |
-
+ total_percent <- total_count / total_n+ |
+ ||
| 168 | +306x | +
+ total_percent >= atleast |
||
| 270 | +169 |
- x+ }) |
||
| 271 | +170 |
} |
||
| 272 | +171 | |||
| 273 | +172 |
- #' @importFrom grid widthDetails+ #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in |
||
| 274 | +173 |
- #' @noRd+ #' the specified columns. |
||
| 275 | +174 |
- widthDetails.decoratedGrob <- function(x) {
+ #' |
||
| 276 | +175 |
- grid::unit(1, "null")+ #' @return |
||
| 277 | +176 |
- }+ #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions |
||
| 278 | +177 |
-
+ #' in the specified columns and checks whether any of them fulfill the threshold. |
||
| 279 | +178 |
- #' @importFrom grid heightDetails+ #' |
||
| 280 | +179 |
- #' @noRd+ #' @examples |
||
| 281 | +180 |
- heightDetails.decoratedGrob <- function(x) {
+ #' \donttest{
|
||
| 282 | +181 |
- grid::unit(1, "null")+ #' # `has_fraction_in_any_col` |
||
| 283 | +182 |
- }+ #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab)) |
||
| 284 | +183 |
-
+ #' prune_table(tab, keep_rows(any_atleast_five_percent)) |
||
| 285 | +184 |
- #' Split text according to available text width+ #' } |
||
| 286 | +185 |
#' |
||
| 287 | +186 |
- #' Dynamically wrap text.+ #' @export |
||
| 288 | +187 |
- #'+ has_fraction_in_any_col <- function(atleast, ...) {
|
||
| 289 | -+ | |||
| 188 | +3x |
- #' @inheritParams grid::grid.text+ assert_proportion_value(atleast, include_boundaries = TRUE) |
||
| 290 | -+ | |||
| 189 | +3x |
- #' @param text (`string`)\cr the text to wrap.+ CombinationFunction(function(table_row) {
|
||
| 291 | -+ | |||
| 190 | +3x |
- #' @param width (`grid::unit`)\cr a unit object specifying maximum width of text.+ row_fractions <- h_row_fractions(table_row, ...) |
||
| 292 | -+ | |||
| 191 | +3x |
- #'+ any(row_fractions >= atleast) |
||
| 293 | +192 |
- #' @return A text `grob`.+ }) |
||
| 294 | +193 |
- #'+ } |
||
| 295 | +194 |
- #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition`+ |
||
| 296 | +195 |
- #'+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
||
| 297 | +196 |
- #' @keywords internal+ #' between the fractions reported in each specified column. |
||
| 298 | +197 |
- split_text_grob <- function(text,+ #' |
||
| 299 | +198 |
- x = grid::unit(0.5, "npc"),+ #' @return |
||
| 300 | +199 |
- y = grid::unit(0.5, "npc"),+ #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each |
||
| 301 | +200 |
- width = grid::unit(1, "npc"),+ #' specified column, and computes the difference of the minimum and maximum. |
||
| 302 | +201 |
- just = "centre",+ #' |
||
| 303 | +202 |
- hjust = NULL,+ #' @examples |
||
| 304 | +203 |
- vjust = NULL,+ #' \donttest{
|
||
| 305 | +204 |
- default.units = "npc", # nolint+ #' # `has_fractions_difference` |
||
| 306 | +205 |
- name = NULL,+ #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab)) |
||
| 307 | +206 |
- gp = grid::gpar(),+ #' prune_table(tab, keep_rows(more_than_five_percent_diff)) |
||
| 308 | +207 |
- vp = NULL) {
+ #' } |
||
| 309 | +208 |
- text <- gsub("\\\\n", "\n", text) # fixing cases of mixed behavior (\n and \\n)
+ #' |
||
| 310 | +209 |
-
+ #' @export |
||
| 311 | +210 |
- if (!grid::is.unit(x)) x <- grid::unit(x, default.units)+ has_fractions_difference <- function(atleast, ...) {
|
||
| 312 | -+ | |||
| 211 | +4x |
- if (!grid::is.unit(y)) y <- grid::unit(y, default.units)+ assert_proportion_value(atleast, include_boundaries = TRUE) |
||
| 313 | -+ | |||
| 212 | +4x |
- if (!grid::is.unit(width)) width <- grid::unit(width, default.units)+ CombinationFunction(function(table_row) {
|
||
| 314 | -+ | |||
| 213 | +246x |
- if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
+ fractions <- h_row_fractions(table_row, ...) |
||
| 315 | -+ | |||
| 214 | +246x |
- if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
+ difference <- diff(range(fractions)) |
||
| 316 | -+ | |||
| 215 | +246x |
- if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
+ difference >= atleast |
||
| 317 | +216 |
-
+ }) |
||
| 318 | +217 |
- if (length(gp) > 0) { # account for effect of gp on text width -> it was bugging when text was empty
+ } |
||
| 319 | +218 |
- horizontal_npc_width_no_gp <- grid::convertWidth(+ |
||
| 320 | +219 |
- grid::grobWidth(+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
||
| 321 | +220 |
- grid::textGrob(+ #' between the counts reported in each specified column. |
||
| 322 | +221 |
- paste0(text, collapse = "\n")+ #' |
||
| 323 | +222 |
- )+ #' @return |
||
| 324 | +223 |
- ), "npc",+ #' * `has_counts_difference()` returns a condition function that extracts the counts of each |
||
| 325 | +224 |
- valueOnly = TRUE+ #' specified column, and computes the difference of the minimum and maximum. |
||
| 326 | +225 |
- )+ #' |
||
| 327 | +226 |
- horizontal_npc_width_with_gp <- grid::convertWidth(grid::grobWidth(+ #' @examples |
||
| 328 | +227 |
- grid::textGrob(+ #' \donttest{
|
||
| 329 | +228 |
- paste0(text, collapse = "\n"),+ #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab)) |
||
| 330 | +229 |
- gp = gp+ #' prune_table(tab, keep_rows(more_than_one_diff)) |
||
| 331 | +230 |
- )+ #' } |
||
| 332 | +231 |
- ), "npc", valueOnly = TRUE)+ #' |
||
| 333 | +232 |
-
+ #' @export |
||
| 334 | +233 |
- # Adapting width to the input gpar (it is normalized so does not matter what is text)+ has_counts_difference <- function(atleast, ...) {
|
||
| 335 | -+ | |||
| 234 | +4x |
- width <- width * horizontal_npc_width_no_gp / horizontal_npc_width_with_gp+ checkmate::assert_count(atleast) |
||
| 336 | -+ | |||
| 235 | +4x |
- }+ CombinationFunction(function(table_row) {
|
||
| 337 | -+ | |||
| 236 | +30x |
-
+ counts <- h_row_counts(table_row, ...) |
||
| 338 | -+ | |||
| 237 | +30x |
- ## if it is a fixed unit then we do not need to recalculate when viewport resized+ difference <- diff(range(counts)) |
||
| 339 | -+ | |||
| 238 | +30x |
- if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) &&+ difference >= atleast |
||
| 340 | +239 |
- attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
+ }) |
||
| 341 | +240 |
- attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")+ } |
| 342 | +1 |
- }+ #' Count patients with marked laboratory abnormalities |
||
| 343 | +2 |
-
+ #' |
||
| 344 | +3 |
- # Fix for split_string in case of residual \n (otherwise is counted as character)+ #' @description `r lifecycle::badge("stable")`
|
||
| 345 | +4 |
- text2 <- unlist(+ #' |
||
| 346 | +5 |
- strsplit(+ #' The analyze function [count_abnormal_by_marked()] creates a layout element to count patients with marked laboratory |
||
| 347 | +6 |
- paste0(text, collapse = "\n"), # for "" cases+ #' abnormalities for each direction of abnormality, categorized by parameter value. |
||
| 348 | +7 |
- "\n"+ #' |
||
| 349 | +8 |
- )+ #' This function analyzes primary analysis variable `var` which indicates whether a single, replicated, |
||
| 350 | +9 |
- )+ #' or last marked laboratory abnormality was observed. Levels of `var` to include for each marked lab |
||
| 351 | +10 |
-
+ #' abnormality (`single` and `last_replicated`) can be supplied via the `category` parameter. Additional |
||
| 352 | +11 |
- # Final grid text with cat-friendly split_string+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults |
||
| 353 | +12 |
- grid::grid.text(+ #' to `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a |
||
| 354 | +13 |
- label = split_string(text2, width),+ #' variable to indicate parameter values, and `direction` (defaults to `abn_dir`), a variable to indicate |
||
| 355 | +14 |
- x = x, y = y,+ #' abnormality directions. |
||
| 356 | +15 |
- just = just,+ #' |
||
| 357 | +16 |
- hjust = hjust,+ #' For each combination of `param` and `direction` levels, marked lab abnormality counts are calculated |
||
| 358 | +17 |
- vjust = vjust,+ #' as follows: |
||
| 359 | +18 |
- rot = 0,+ #' * `Single, not last` & `Last or replicated`: The number of patients with `Single, not last` |
||
| 360 | +19 |
- check.overlap = FALSE,+ #' and `Last or replicated` values, respectively. |
||
| 361 | +20 |
- name = name,+ #' * `Any`: The number of patients with either single or replicated marked abnormalities. |
||
| 362 | +21 |
- gp = gp,+ #' |
||
| 363 | +22 |
- vp = vp,+ #' Fractions are calculated by dividing the above counts by the number of patients with at least one |
||
| 364 | +23 |
- draw = FALSE+ #' valid measurement recorded during the analysis. |
||
| 365 | +24 |
- )+ #' |
||
| 366 | +25 |
- }+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two |
||
| 367 | +26 |
-
+ #' row splits, one on variable `param` and one on variable `direction`. |
||
| 368 | +27 |
- #' @importFrom grid validDetails+ #' |
||
| 369 | +28 |
- #' @noRd+ #' @inheritParams argument_convention |
||
| 370 | +29 |
- validDetails.dynamicSplitText <- function(x) {
+ #' @param category (`list`)\cr a list with different marked category names for single |
||
| 371 | +30 |
- checkmate::assert_character(x$text)+ #' and last or replicated. |
||
| 372 | +31 |
- checkmate::assert_true(grid::is.unit(x$width))+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 373 | +32 |
- checkmate::assert_vector(x$width, len = 1)+ #' |
||
| 374 | +33 |
- x+ #' Options are: ``r shQuote(get_stats("abnormal_by_marked"))``
|
||
| 375 | +34 |
- }+ #' |
||
| 376 | +35 |
-
+ #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has |
||
| 377 | +36 |
- #' @importFrom grid heightDetails+ #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the |
||
| 378 | +37 |
- #' @noRd+ #' patient will be counted only under the `Last or replicated` category. |
||
| 379 | +38 |
- heightDetails.dynamicSplitText <- function(x) {
+ #' |
||
| 380 | +39 |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ #' @name abnormal_by_marked |
||
| 381 | +40 |
- attr(x$text, "fixed_text")+ #' @order 1 |
||
| 382 | +41 |
- } else {
+ NULL |
||
| 383 | +42 |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ |
||
| 384 | +43 |
- }+ #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities. |
||
| 385 | +44 |
- grid::stringHeight(txt)+ #' |
||
| 386 | +45 |
- }+ #' @return |
||
| 387 | +46 |
-
+ #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`, |
||
| 388 | +47 |
- #' @importFrom grid widthDetails+ #' `Last or replicated`, and `Any` results. |
||
| 389 | +48 |
- #' @noRd+ #' |
||
| 390 | +49 |
- widthDetails.dynamicSplitText <- function(x) {
+ #' @keywords internal |
||
| 391 | +50 |
- x$width+ s_count_abnormal_by_marked <- function(df, |
||
| 392 | +51 |
- }+ .var = "AVALCAT1", |
||
| 393 | +52 |
-
+ .spl_context, |
||
| 394 | +53 |
- #' @importFrom grid drawDetails+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
||
| 395 | +54 |
- #' @noRd+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
|
||
| 396 | -+ | |||
| 55 | +3x |
- drawDetails.dynamicSplitText <- function(x, recording) {
+ checkmate::assert_string(.var) |
||
| 397 | -+ | |||
| 56 | +3x |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ checkmate::assert_list(variables) |
||
| 398 | -+ | |||
| 57 | +3x |
- attr(x$text, "fixed_text")+ checkmate::assert_list(category) |
||
| 399 | -+ | |||
| 58 | +3x |
- } else {
+ checkmate::assert_subset(names(category), c("single", "last_replicated"))
|
||
| 400 | -+ | |||
| 59 | +3x |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ checkmate::assert_subset(names(variables), c("id", "param", "direction"))
|
||
| 401 | -+ | |||
| 60 | +3x |
- }+ checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1) |
||
| 402 | +61 | |||
| 403 | -+ | |||
| 62 | +2x |
- x$width <- NULL+ assert_df_with_variables(df, c(aval = .var, variables)) |
||
| 404 | -+ | |||
| 63 | +2x |
- x$label <- txt+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
||
| 405 | -+ | |||
| 64 | +2x |
- x$text <- NULL+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
||
| 406 | +65 |
- class(x) <- c("text", class(x)[-1])
+
|
||
| 407 | +66 | |||
| 408 | -+ | |||
| 67 | +2x |
- grid::grid.draw(x)+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
||
| 409 | +68 |
- }+ # Patients in the denominator have at least one post-baseline visit. |
||
| 410 | -+ | |||
| 69 | +2x |
- # nocov end+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
||
| 411 | -+ | |||
| 70 | +2x |
-
+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
||
| 412 | +71 |
- # Adapted from Paul Murell R Graphics 2nd Edition+ # Some subjects may have a record for high and low directions but |
||
| 413 | +72 |
- # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R+ # should be counted only once. |
||
| 414 | -+ | |||
| 73 | +2x |
- split_string <- function(text, width) {
+ denom <- length(unique(subj_cur_col)) |
||
| 415 | -26x | +|||
| 74 | +
- strings <- strsplit(text, " ")+ |
|||
| 416 | -26x | +75 | +2x |
- out_string <- NA+ if (denom != 0) {
|
| 417 | -26x | +76 | +2x |
- for (string_i in seq_along(strings)) {
+ subjects_last_replicated <- unique( |
| 418 | -48x | +77 | +2x |
- newline_str <- strings[[string_i]]+ df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE] |
| 419 | -6x | +|||
| 78 | +
- if (length(newline_str) == 0) newline_str <- ""+ ) |
|||
| 420 | -48x | +79 | +2x |
- if (is.na(out_string[string_i])) {
+ subjects_single <- unique( |
| 421 | -48x | +80 | +2x |
- out_string[string_i] <- newline_str[[1]][[1]]+ df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE] |
| 422 | -48x | +|||
| 81 | +
- linewidth <- grid::stringWidth(out_string[string_i])+ ) |
|||
| 423 | +82 |
- }+ # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group. |
||
| 424 | -48x | +83 | +2x |
- gapwidth <- grid::stringWidth(" ")
+ subjects_single <- setdiff(subjects_single, subjects_last_replicated) |
| 425 | -48x | +84 | +2x |
- availwidth <- as.numeric(width)+ n_single <- length(subjects_single) |
| 426 | -48x | +85 | +2x |
- if (length(newline_str) > 1) {
+ n_last_replicated <- length(subjects_last_replicated) |
| 427 | -12x | +86 | +2x |
- for (i in seq(2, length(newline_str))) {
+ n_any <- n_single + n_last_replicated |
| 428 | -184x | +87 | +2x |
- width_i <- grid::stringWidth(newline_str[i])+ result <- list(count_fraction = list( |
| 429 | -+ | |||
| 88 | +2x |
- # Main conversion of allowed text width -> npc units are 0<npc<1. External viewport is used for conversion+ "Single, not last" = c(n_single, n_single / denom), |
||
| 430 | -184x | +89 | +2x |
- if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ "Last or replicated" = c(n_last_replicated, n_last_replicated / denom), |
| 431 | -177x | +90 | +2x |
- sep <- " "+ "Any Abnormality" = c(n_any, n_any / denom) |
| 432 | -177x | +|||
| 91 | +
- linewidth <- linewidth + gapwidth + width_i+ )) |
|||
| 433 | +92 |
- } else {
+ } else {
|
||
| 434 | -7x | +|||
| 93 | +! |
- sep <- "\n"+ result <- list(count_fraction = list( |
||
| 435 | -7x | +|||
| 94 | +! |
- linewidth <- width_i+ "Single, not last" = c(0, 0), |
||
| 436 | -+ | |||
| 95 | +! |
- }+ "Last or replicated" = c(0, 0), |
||
| 437 | -184x | +|||
| 96 | +! |
- out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep)+ "Any Abnormality" = c(0, 0) |
||
| 438 | +97 |
- }+ )) |
||
| 439 | +98 |
- }+ } |
||
| 440 | +99 |
- }+ |
||
| 441 | -26x | +100 | +2x |
- paste(out_string, collapse = "\n")+ result |
| 442 | +101 |
} |
||
| 443 | +102 | |||
| 444 | +103 |
- #' Update page number+ #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun` |
||
| 445 | +104 |
- #'+ #' in `count_abnormal_by_marked()`. |
||
| 446 | +105 |
- #' Automatically updates page number.+ #' |
||
| 447 | +106 |
- #'+ #' @return |
||
| 448 | +107 |
- #' @param npages (`numeric(1)`)\cr total number of pages.+ #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 449 | +108 |
- #' @param ... arguments passed on to [decorate_grob()].+ #' |
||
| 450 | +109 |
- #'+ #' @keywords internal |
||
| 451 | +110 |
- #' @return Closure that increments the page number.+ a_count_abnormal_by_marked <- make_afun( |
||
| 452 | +111 |
- #'+ s_count_abnormal_by_marked, |
||
| 453 | +112 |
- #' @keywords internal+ .formats = c(count_fraction = format_count_fraction) |
||
| 454 | +113 |
- decorate_grob_factory <- function(npages, ...) {
+ ) |
||
| 455 | -2x | +|||
| 114 | +
- current_page <- 0+ |
|||
| 456 | -2x | +|||
| 115 | +
- function(grob) {
+ #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments |
|||
| 457 | -7x | +|||
| 116 | +
- current_page <<- current_page + 1+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 458 | -7x | +|||
| 117 | +
- if (current_page > npages) {
+ #' |
|||
| 459 | -1x | +|||
| 118 | +
- stop(paste("current page is", current_page, "but max.", npages, "specified."))
+ #' @return |
|||
| 460 | +119 |
- }+ #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions, |
||
| 461 | -6x | +|||
| 120 | +
- decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 462 | +121 |
- }+ #' the statistics from `s_count_abnormal_by_marked()` to the table layout. |
||
| 463 | +122 |
- }+ #' |
||
| 464 | +123 |
-
+ #' @examples |
||
| 465 | +124 |
- #' Decorate set of `grob`s and add page numbering+ #' library(dplyr) |
||
| 466 | +125 |
#' |
||
| 467 | +126 |
- #' @description `r lifecycle::badge("stable")`
+ #' df <- data.frame( |
||
| 468 | +127 |
- #'+ #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))), |
||
| 469 | +128 |
- #' Note that this uses the [decorate_grob_factory()] function.+ #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
|
||
| 470 | +129 |
- #'+ #' ANRIND = factor(c( |
||
| 471 | +130 |
- #' @param grobs (`list` of `grob`)\cr a list of grid grobs.+ #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH", |
||
| 472 | +131 |
- #' @param ... arguments passed on to [decorate_grob()].+ #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW", |
||
| 473 | +132 |
- #'+ #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW" |
||
| 474 | +133 |
- #' @return A decorated grob.+ #' )), |
||
| 475 | +134 |
- #'+ #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
|
||
| 476 | +135 |
- #' @examples+ #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
|
||
| 477 | +136 |
- #' library(ggplot2)+ #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
|
||
| 478 | +137 |
- #' library(grid)+ #' stringsAsFactors = FALSE |
||
| 479 | +138 |
- #' g <- with(data = iris, {
+ #' ) |
||
| 480 | +139 |
- #' list(+ #' |
||
| 481 | +140 |
- #' ggplot2::ggplotGrob(+ #' df <- df %>% |
||
| 482 | +141 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) ++ #' mutate(abn_dir = factor( |
||
| 483 | +142 |
- #' ggplot2::geom_point()+ #' case_when( |
||
| 484 | +143 |
- #' ),+ #' ANRIND == "LOW LOW" ~ "Low", |
||
| 485 | +144 |
- #' ggplot2::ggplotGrob(+ #' ANRIND == "HIGH HIGH" ~ "High", |
||
| 486 | +145 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) ++ #' TRUE ~ "" |
||
| 487 | +146 |
- #' ggplot2::geom_point()+ #' ), |
||
| 488 | +147 |
- #' ),+ #' levels = c("Low", "High")
|
||
| 489 | +148 |
- #' ggplot2::ggplotGrob(+ #' )) |
||
| 490 | +149 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) ++ #' |
||
| 491 | +150 |
- #' ggplot2::geom_point()+ #' # Select only post-baseline records. |
||
| 492 | +151 |
- #' ),+ #' df <- df %>% filter(ONTRTFL == "Y") |
||
| 493 | +152 |
- #' ggplot2::ggplotGrob(+ #' df_crp <- df %>% |
||
| 494 | +153 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) ++ #' filter(PARAMCD == "CRP") %>% |
||
| 495 | +154 |
- #' ggplot2::geom_point()+ #' droplevels() |
||
| 496 | +155 |
- #' ),+ #' full_parent_df <- list(df_crp, "not_needed") |
||
| 497 | +156 |
- #' ggplot2::ggplotGrob(+ #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed") |
||
| 498 | +157 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) ++ #' spl_context <- data.frame( |
||
| 499 | +158 |
- #' ggplot2::geom_point()+ #' split = c("PARAMCD", "GRADE_DIR"),
|
||
| 500 | +159 |
- #' ),+ #' full_parent_df = I(full_parent_df), |
||
| 501 | +160 |
- #' ggplot2::ggplotGrob(+ #' cur_col_subset = I(cur_col_subset) |
||
| 502 | +161 |
- #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) ++ #' ) |
||
| 503 | +162 |
- #' ggplot2::geom_point()+ #' |
||
| 504 | +163 |
- #' )+ #' map <- unique( |
||
| 505 | +164 |
- #' )+ #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
|
||
| 506 | +165 |
- #' })+ #' ) %>% |
||
| 507 | +166 |
- #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")+ #' lapply(as.character) %>% |
||
| 508 | +167 |
- #'+ #' as.data.frame() %>% |
||
| 509 | +168 |
- #' draw_grob(lg[[1]])+ #' arrange(PARAMCD, abn_dir) |
||
| 510 | +169 |
- #' draw_grob(lg[[2]])+ #' |
||
| 511 | +170 |
- #' draw_grob(lg[[6]])+ #' basic_table() %>% |
||
| 512 | +171 |
- #'+ #' split_cols_by("ARMCD") %>%
|
||
| 513 | +172 |
- #' @export+ #' split_rows_by("PARAMCD") %>%
|
||
| 514 | +173 |
- decorate_grob_set <- function(grobs, ...) {
- |
- ||
| 515 | -1x | -
- n <- length(grobs)+ #' summarize_num_patients( |
||
| 516 | -1x | +|||
| 174 | +
- lgf <- decorate_grob_factory(npages = n, ...)+ #' var = "USUBJID", |
|||
| 517 | -1x | +|||
| 175 | +
- lapply(grobs, lgf)+ #' .stats = "unique_count" |
|||
| 518 | +176 |
- }+ #' ) %>% |
| 1 | +177 |
- #' Helper function for tabulation of a single biomarker result+ #' split_rows_by( |
||
| 2 | +178 |
- #'+ #' "abn_dir", |
||
| 3 | +179 |
- #' @description `r lifecycle::badge("stable")`
+ #' split_fun = trim_levels_to_map(map) |
||
| 4 | +180 |
- #'+ #' ) %>% |
||
| 5 | +181 |
- #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples.+ #' count_abnormal_by_marked( |
||
| 6 | +182 |
- #' This function is a wrapper for [rtables::summarize_row_groups()].+ #' var = "AVALCAT1", |
||
| 7 | +183 |
- #'+ #' variables = list( |
||
| 8 | +184 |
- #' @inheritParams argument_convention+ #' id = "USUBJID", |
||
| 9 | +185 |
- #' @param df (`data.frame`)\cr results for a single biomarker.+ #' param = "PARAMCD", |
||
| 10 | +186 |
- #' @param afuns (named `list` of `function`)\cr analysis functions.+ #' direction = "abn_dir" |
||
| 11 | +187 |
- #' @param colvars (named `list`)\cr named list with elements `vars` (variables to tabulate) and `labels` (their labels).+ #' ) |
||
| 12 | +188 |
- #'+ #' ) %>% |
||
| 13 | +189 |
- #' @return An `rtables` table object with statistics in columns.+ #' build_table(df = df) |
||
| 14 | +190 |
#' |
||
| 15 | +191 |
- #' @export+ #' basic_table() %>% |
||
| 16 | +192 |
- h_tab_one_biomarker <- function(df,+ #' split_cols_by("ARMCD") %>%
|
||
| 17 | +193 |
- afuns,+ #' split_rows_by("PARAMCD") %>%
|
||
| 18 | +194 |
- colvars,+ #' summarize_num_patients( |
||
| 19 | +195 |
- na_str = default_na_str(),+ #' var = "USUBJID", |
||
| 20 | +196 |
- .indent_mods = 0L,+ #' .stats = "unique_count" |
||
| 21 | +197 |
- ...) {
- |
- ||
| 22 | -18x | -
- extra_args <- list(...)+ #' ) %>% |
||
| 23 | +198 |
-
+ #' split_rows_by( |
||
| 24 | +199 |
- # Create "ci" column from "lcl" and "ucl"- |
- ||
| 25 | -18x | -
- df$ci <- combine_vectors(df$lcl, df$ucl)+ #' "abn_dir", |
||
| 26 | +200 | - - | -||
| 27 | -18x | -
- lyt <- basic_table()+ #' split_fun = trim_levels_in_group("abn_dir")
|
||
| 28 | +201 |
-
+ #' ) %>% |
||
| 29 | +202 |
- # Row split by row type - only keep the content rows here.- |
- ||
| 30 | -18x | -
- lyt <- split_rows_by(- |
- ||
| 31 | -18x | -
- lyt = lyt,- |
- ||
| 32 | -18x | -
- var = "row_type",- |
- ||
| 33 | -18x | -
- split_fun = keep_split_levels("content"),
- |
- ||
| 34 | -18x | -
- nested = FALSE+ #' count_abnormal_by_marked( |
||
| 35 | +203 |
- )+ #' var = "AVALCAT1", |
||
| 36 | +204 |
-
+ #' variables = list( |
||
| 37 | +205 |
- # Summarize rows with all patients.- |
- ||
| 38 | -18x | -
- lyt <- summarize_row_groups(- |
- ||
| 39 | -18x | -
- lyt = lyt,- |
- ||
| 40 | -18x | -
- var = "var_label",- |
- ||
| 41 | -18x | -
- cfun = afuns,- |
- ||
| 42 | -18x | -
- na_str = na_str,+ #' id = "USUBJID", |
||
| 43 | -18x | +|||
| 206 | +
- indent_mod = .indent_mods,+ #' param = "PARAMCD", |
|||
| 44 | -18x | +|||
| 207 | +
- extra_args = extra_args+ #' direction = "abn_dir" |
|||
| 45 | +208 |
- )+ #' ) |
||
| 46 | +209 |
-
+ #' ) %>% |
||
| 47 | +210 |
- # Split cols by the multiple variables to populate into columns.+ #' build_table(df = df) |
||
| 48 | -18x | +|||
| 211 | +
- lyt <- split_cols_by_multivar(+ #' |
|||
| 49 | -18x | +|||
| 212 | +
- lyt = lyt,+ #' @export |
|||
| 50 | -18x | +|||
| 213 | +
- vars = colvars$vars,+ #' @order 2 |
|||
| 51 | -18x | +|||
| 214 | +
- varlabels = colvars$labels+ count_abnormal_by_marked <- function(lyt, |
|||
| 52 | +215 |
- )+ var, |
||
| 53 | +216 |
-
+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
||
| 54 | +217 |
- # If there is any subgroup variables, we extend the layout accordingly.+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"), |
||
| 55 | -18x | +|||
| 218 | +
- if ("analysis" %in% df$row_type) {
+ na_str = default_na_str(), |
|||
| 56 | +219 |
- # Now only continue with the subgroup rows.+ nested = TRUE, |
||
| 57 | -10x | +|||
| 220 | +
- lyt <- split_rows_by(+ ..., |
|||
| 58 | -10x | +|||
| 221 | +
- lyt = lyt,+ .stats = NULL, |
|||
| 59 | -10x | +|||
| 222 | +
- var = "row_type",+ .formats = NULL, |
|||
| 60 | -10x | +|||
| 223 | +
- split_fun = keep_split_levels("analysis"),
+ .labels = NULL, |
|||
| 61 | -10x | +|||
| 224 | +
- nested = FALSE,+ .indent_mods = NULL) {
|
|||
| 62 | -10x | +225 | +1x |
- child_labels = "hidden"+ checkmate::assert_string(var) |
| 63 | +226 |
- )+ |
||
| 64 | -+ | |||
| 227 | +1x |
-
+ extra_args <- list(category = category, variables = variables, ...) |
||
| 65 | +228 |
- # Split by the subgroup variable.+ |
||
| 66 | -10x | +229 | +1x |
- lyt <- split_rows_by(+ afun <- make_afun( |
| 67 | -10x | +230 | +1x |
- lyt = lyt,+ a_count_abnormal_by_marked, |
| 68 | -10x | +231 | +1x |
- var = "var",+ .stats = .stats, |
| 69 | -10x | +232 | +1x |
- labels_var = "var_label",+ .formats = .formats, |
| 70 | -10x | +233 | +1x |
- nested = TRUE,+ .labels = .labels, |
| 71 | -10x | +234 | +1x |
- child_labels = "visible",+ .indent_mods = .indent_mods, |
| 72 | -10x | +235 | +1x |
- indent_mod = .indent_mods * 2+ .ungroup_stats = "count_fraction" |
| 73 | +236 |
- )+ ) |
||
| 74 | +237 | |||
| 75 | -+ | |||
| 238 | +1x |
- # Then analyze colvars for each subgroup.+ lyt <- analyze( |
||
| 76 | -10x | +239 | +1x |
- lyt <- summarize_row_groups(+ lyt = lyt, |
| 77 | -10x | +240 | +1x |
- lyt = lyt,+ vars = var, |
| 78 | -10x | +241 | +1x |
- cfun = afuns,+ afun = afun, |
| 79 | -10x | +242 | +1x |
- var = "subgroup",+ na_str = na_str, |
| 80 | -10x | +243 | +1x |
- na_str = na_str,+ nested = nested, |
| 81 | -10x | +244 | +1x |
- extra_args = extra_args+ show_labels = "hidden", |
| 82 | -+ | |||
| 245 | +1x |
- )+ extra_args = extra_args |
||
| 83 | +246 |
- }+ ) |
||
| 84 | -18x | +247 | +1x |
- build_table(lyt, df = df)+ lyt |
| 85 | +248 |
}@@ -158762,14 +157647,14 @@ tern coverage - 95.65% |
| 1 |
- #' Count patients with abnormal range values+ #' Helper functions for tabulating survival duration by subgroup |
||
| 5 |
- #' The analyze function [count_abnormal()] creates a layout element to count patients with abnormal analysis range+ #' Helper functions that tabulate in a data frame statistics such as median survival |
||
| 6 |
- #' values in each direction.+ #' time and hazard ratio for population subgroups. |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates abnormal range results.+ #' @inheritParams argument_convention |
||
| 9 |
- #' Additional analysis variables that can be supplied as a list via the `variables` parameter are+ #' @inheritParams survival_coxph_pairwise |
||
| 10 |
- #' `id` (defaults to `USUBJID`), a variable to indicate unique subject identifiers, and `baseline`+ #' @inheritParams survival_duration_subgroups |
||
| 11 |
- #' (defaults to `BNRIND`), a variable to indicate baseline reference ranges.+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 13 |
- #' For each direction specified via the `abnormal` parameter (e.g. High or Low), a fraction of+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 14 |
- #' patient counts is returned, with numerator and denominator calculated as follows:+ #' |
||
| 15 |
- #' * `num`: The number of patients with this abnormality recorded while on treatment.+ #' @examples |
||
| 16 |
- #' * `denom`: The total number of patients with at least one post-baseline assessment.+ #' library(dplyr) |
||
| 17 |
- #'+ #' library(forcats) |
||
| 18 |
- #' This function assumes that `df` has been filtered to only include post-baseline records.+ #' |
||
| 19 |
- #'+ #' adtte <- tern_ex_adtte |
||
| 20 |
- #' @inheritParams argument_convention+ #' |
||
| 21 |
- #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to+ #' # Save variable labels before data processing steps. |
||
| 22 |
- #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list,+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 23 |
- #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
+ #' |
||
| 24 |
- #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality+ #' adtte_f <- adtte %>% |
||
| 25 |
- #' from numerator and denominator.+ #' filter( |
||
| 26 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' PARAMCD == "OS", |
||
| 27 |
- #'+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 28 |
- #' Options are: ``r shQuote(get_stats("abnormal"))``
+ #' SEX %in% c("M", "F")
|
||
| 29 |
- #'+ #' ) %>% |
||
| 30 |
- #' @note+ #' mutate( |
||
| 31 |
- #' * `count_abnormal()` only considers a single variable that contains multiple abnormal levels.+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 32 |
- #' * `df` should be filtered to only include post-baseline records.+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 33 |
- #' * The denominator includes patients that may have other abnormal levels at baseline,+ #' SEX = droplevels(SEX), |
||
| 34 |
- #' and patients missing baseline records. Patients with these abnormalities at+ #' is_event = CNSR == 0 |
||
| 35 |
- #' baseline can be optionally excluded from numerator and denominator via the+ #' ) |
||
| 36 |
- #' `exclude_base_abn` parameter.+ #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
|
||
| 37 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 38 |
- #' @name abnormal+ #' |
||
| 39 |
- #' @include formatting_functions.R+ #' @name h_survival_duration_subgroups |
||
| 40 |
- #' @order 1+ NULL |
||
| 41 |
- NULL+ |
||
| 42 |
-
+ #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame of median survival times by arm. |
||
| 43 |
- #' @describeIn abnormal Statistics function which counts patients with abnormal range values+ #' |
||
| 44 |
- #' for a single `abnormal` level.+ #' @return |
||
| 45 |
- #'+ #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`. |
||
| 46 |
- #' @return+ #' |
||
| 47 |
- #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients.+ #' @examples |
||
| 48 |
- #'+ #' # Extract median survival time for one group. |
||
| 49 |
- #' @keywords internal+ #' h_survtime_df( |
||
| 50 |
- s_count_abnormal <- function(df,+ #' tte = adtte_f$AVAL, |
||
| 51 |
- .var,+ #' is_event = adtte_f$is_event, |
||
| 52 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ #' arm = adtte_f$ARM |
||
| 53 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ #' ) |
||
| 54 |
- exclude_base_abn = FALSE) {
+ #' |
||
| 55 | -4x | +
- checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE)+ #' @export |
|
| 56 | -4x | +
- checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]])))+ h_survtime_df <- function(tte, is_event, arm) {
|
|
| 57 | -4x | +79x |
- checkmate::assert_factor(df[[.var]])+ checkmate::assert_numeric(tte) |
| 58 | -4x | +78x |
- checkmate::assert_flag(exclude_base_abn)+ checkmate::assert_logical(is_event, len = length(tte)) |
| 59 | -4x | +78x |
- assert_df_with_variables(df, c(range = .var, variables))+ assert_valid_factor(arm, len = length(tte)) |
| 60 | -4x | +
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+
|
|
| 61 | -4x | +78x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ df_tte <- data.frame( |
| 62 | -+ | 78x |
-
+ tte = tte, |
| 63 | -4x | +78x |
- count_abnormal_single <- function(abn_name, abn) {
+ is_event = is_event, |
| 64 | -+ | 78x |
- # Patients in the denominator fulfill:+ stringsAsFactors = FALSE |
| 65 |
- # - have at least one post-baseline visit+ ) |
||
| 66 |
- # - their baseline must not be abnormal if `exclude_base_abn`.+ |
||
| 67 | -8x | +
- if (exclude_base_abn) {
+ # Delete NAs |
|
| 68 | -4x | +78x |
- denom_select <- !(df[[variables$baseline]] %in% abn)+ non_missing_rows <- stats::complete.cases(df_tte) |
| 69 | -+ | 78x |
- } else {
+ df_tte <- df_tte[non_missing_rows, ] |
| 70 | -4x | +78x |
- denom_select <- TRUE+ arm <- arm[non_missing_rows] |
| 71 |
- }+ |
||
| 72 | -8x | +78x |
- denom <- length(unique(df[denom_select, variables$id, drop = TRUE]))+ lst_tte <- split(df_tte, arm) |
| 73 | -+ | 78x |
-
+ lst_results <- Map(function(x, arm) {
|
| 74 | -+ | 156x |
- # Patients in the numerator fulfill:+ if (nrow(x) > 0) {
|
| 75 | -+ | 152x |
- # - have at least one post-baseline visit with the required abnormality level+ s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event") |
| 76 | -+ | 152x |
- # - are part of the denominator patients.+ median_est <- unname(as.numeric(s_surv$median)) |
| 77 | -8x | +152x |
- num_select <- (df[[.var]] %in% abn) & denom_select+ n_events <- sum(x$is_event) |
| 78 | -8x | +
- num <- length(unique(df[num_select, variables$id, drop = TRUE]))+ } else {
|
|
| 79 | -+ | 4x |
-
+ median_est <- NA |
| 80 | -8x | +4x |
- formatters::with_label(c(num = num, denom = denom), abn_name)+ n_events <- NA |
| 81 |
- }+ } |
||
| 83 | -+ | 156x |
- # This will define the abnormal levels theoretically possible for a specific lab parameter+ data.frame( |
| 84 | -+ | 156x |
- # within a split level of a layout.+ arm = arm, |
| 85 | -4x | +156x |
- abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]]))+ n = nrow(x), |
| 86 | -4x | +156x |
- abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))]+ n_events = n_events, |
| 87 | -+ | 156x |
-
+ median = median_est, |
| 88 | -4x | +156x |
- result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE)+ stringsAsFactors = FALSE |
| 89 | -4x | +
- result <- list(fraction = result)+ ) |
|
| 90 | -4x | +78x |
- result+ }, lst_tte, names(lst_tte)) |
| 91 |
- }+ |
||
| 92 | -+ | 78x |
-
+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 93 | -+ | 78x |
- #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`.+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 94 | -+ | 78x |
- #'+ df |
| 95 |
- #' @return+ } |
||
| 96 |
- #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()].+ |
||
| 97 |
- #'+ #' @describeIn h_survival_duration_subgroups Summarizes median survival times by arm and across subgroups |
||
| 98 |
- #' @keywords internal+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 99 |
- a_count_abnormal <- make_afun(+ #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 100 |
- s_count_abnormal,+ #' groupings for `subgroups` variables. |
||
| 101 |
- .formats = c(fraction = format_fraction)+ #' |
||
| 102 |
- )+ #' @return |
||
| 103 |
-
+ #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`, |
||
| 104 |
- #' @describeIn abnormal Layout-creating function which can take statistics function arguments+ #' `var`, `var_label`, and `row_type`. |
||
| 105 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 106 |
- #'+ #' @examples |
||
| 107 |
- #' @return+ #' # Extract median survival time for multiple groups. |
||
| 108 |
- #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions,+ #' h_survtime_subgroups_df( |
||
| 109 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' variables = list( |
||
| 110 |
- #' the statistics from `s_count_abnormal()` to the table layout.+ #' tte = "AVAL", |
||
| 111 |
- #'+ #' is_event = "is_event", |
||
| 112 |
- #' @examples+ #' arm = "ARM", |
||
| 113 |
- #' library(dplyr)+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 114 |
- #'+ #' ), |
||
| 115 |
- #' df <- data.frame(+ #' data = adtte_f |
||
| 116 |
- #' USUBJID = as.character(c(1, 1, 2, 2)),+ #' ) |
||
| 117 |
- #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' |
||
| 118 |
- #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ #' # Define groupings for BMRKR2 levels. |
||
| 119 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ #' h_survtime_subgroups_df( |
||
| 120 |
- #' stringsAsFactors = FALSE+ #' variables = list( |
||
| 121 |
- #' )+ #' tte = "AVAL", |
||
| 122 |
- #'+ #' is_event = "is_event", |
||
| 123 |
- #' # Select only post-baseline records.+ #' arm = "ARM", |
||
| 124 |
- #' df <- df %>%+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 125 |
- #' filter(ONTRTFL == "Y")+ #' ), |
||
| 126 |
- #'+ #' data = adtte_f, |
||
| 127 |
- #' # Layout creating function.+ #' groups_lists = list( |
||
| 128 |
- #' basic_table() %>%+ #' BMRKR2 = list( |
||
| 129 |
- #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>%+ #' "low" = "LOW", |
||
| 130 |
- #' build_table(df)+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 131 |
- #'+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 132 |
- #' # Passing of statistics function and formatting arguments.+ #' ) |
||
| 133 |
- #' df2 <- data.frame(+ #' ) |
||
| 134 |
- #' ID = as.character(c(1, 1, 2, 2)),+ #' ) |
||
| 135 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' |
||
| 136 |
- #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ #' @export |
||
| 137 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ h_survtime_subgroups_df <- function(variables, |
||
| 138 |
- #' stringsAsFactors = FALSE+ data, |
||
| 139 |
- #' )+ groups_lists = list(), |
||
| 140 |
- #'+ label_all = "All Patients") {
|
||
| 141 | -+ | 15x |
- #' # Select only post-baseline records.+ checkmate::assert_character(variables$tte) |
| 142 | -+ | 15x |
- #' df2 <- df2 %>%+ checkmate::assert_character(variables$is_event) |
| 143 | -+ | 15x |
- #' filter(ONTRTFL == "Y")+ checkmate::assert_character(variables$arm) |
| 144 | -+ | 15x |
- #'+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 145 |
- #' basic_table() %>%+ |
||
| 146 | -+ | 15x |
- #' count_abnormal(+ assert_df_with_variables(data, variables) |
| 147 |
- #' var = "RANGE",+ |
||
| 148 | -+ | 15x |
- #' abnormal = list(low = "LOW", high = "HIGH"),+ checkmate::assert_string(label_all) |
| 149 |
- #' variables = list(id = "ID", baseline = "BL_RANGE")+ |
||
| 150 |
- #' ) %>%+ # Add All Patients. |
||
| 151 | -+ | 15x |
- #' build_table(df2)+ result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]]) |
| 152 | -+ | 15x |
- #'+ result_all$subgroup <- label_all |
| 153 | -+ | 15x |
- #' @export+ result_all$var <- "ALL" |
| 154 | -+ | 15x |
- #' @order 2+ result_all$var_label <- label_all |
| 155 | -+ | 15x |
- count_abnormal <- function(lyt,+ result_all$row_type <- "content" |
| 156 |
- var,+ |
||
| 157 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ # Add Subgroups. |
||
| 158 | -+ | 15x |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ if (is.null(variables$subgroups)) {
|
| 159 | -+ | 3x |
- exclude_base_abn = FALSE,+ result_all |
| 160 |
- na_str = default_na_str(),+ } else {
|
||
| 161 | -+ | 12x |
- nested = TRUE,+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 162 | -+ | 12x |
- ...,+ l_result <- lapply(l_data, function(grp) {
|
| 163 | -+ | 60x |
- table_names = var,+ result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]]) |
| 164 | -+ | 60x |
- .stats = NULL,+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 165 | -+ | 60x |
- .formats = NULL,+ cbind(result, result_labels) |
| 166 |
- .labels = NULL,+ }) |
||
| 167 | -+ | 12x |
- .indent_mods = NULL) {
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 168 | -3x | +12x |
- extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...)+ result_subgroups$row_type <- "analysis" |
| 169 | -+ | 12x |
-
+ rbind( |
| 170 | -3x | +12x |
- afun <- make_afun(+ result_all, |
| 171 | -3x | +12x |
- a_count_abnormal,+ result_subgroups |
| 172 | -3x | +
- .stats = .stats,+ ) |
|
| 173 | -3x | +
- .formats = .formats,+ } |
|
| 174 | -3x | +
- .labels = .labels,+ } |
|
| 175 | -3x | +
- .indent_mods = .indent_mods,+ |
|
| 176 | -3x | +
- .ungroup_stats = "fraction"+ #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame with estimates of |
|
| 177 |
- )+ #' treatment hazard ratio. |
||
| 178 |
-
+ #' |
||
| 179 | -3x | +
- checkmate::assert_string(var)+ #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed. |
|
| 180 |
-
+ #' |
||
| 181 | -3x | +
- analyze(+ #' @return |
|
| 182 | -3x | +
- lyt = lyt,+ #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, |
|
| 183 | -3x | +
- vars = var,+ #' `conf_level`, `pval` and `pval_label`. |
|
| 184 | -3x | +
- afun = afun,+ #' |
|
| 185 | -3x | +
- na_str = na_str,+ #' @examples |
|
| 186 | -3x | +
- nested = nested,+ #' # Extract hazard ratio for one group. |
|
| 187 | -3x | +
- table_names = table_names,+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM) |
|
| 188 | -3x | +
- extra_args = extra_args,+ #' |
|
| 189 | -3x | +
- show_labels = "hidden"+ #' # Extract hazard ratio for one group with stratification factor. |
|
| 190 |
- )+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1) |
||
| 191 |
- }+ #' |
| 1 | +192 |
- #' Bland-Altman analysis+ #' @export |
||
| 2 | +193 |
- #'+ h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
|
||
| 3 | -+ | |||
| 194 | +85x |
- #' @description `r lifecycle::badge("experimental")`
+ checkmate::assert_numeric(tte) |
||
| 4 | -+ | |||
| 195 | +85x |
- #'+ checkmate::assert_logical(is_event, len = length(tte)) |
||
| 5 | -+ | |||
| 196 | +85x |
- #' Statistics function that uses the Bland-Altman method to assess the agreement between two numerical vectors+ assert_valid_factor(arm, n.levels = 2, len = length(tte)) |
||
| 6 | +197 |
- #' and calculates a variety of statistics.+ |
||
| 7 | -+ | |||
| 198 | +85x |
- #'+ df_tte <- data.frame(tte = tte, is_event = is_event) |
||
| 8 | -+ | |||
| 199 | +85x |
- #' @inheritParams argument_convention+ strata_vars <- NULL |
||
| 9 | +200 |
- #' @param y (`numeric`)\cr vector of numbers we want to analyze, to be compared with `x`.+ |
||
| 10 | -+ | |||
| 201 | +85x |
- #'+ if (!is.null(strata_data)) {
|
||
| 11 | -+ | |||
| 202 | +5x |
- #' @return+ if (is.data.frame(strata_data)) {
|
||
| 12 | -+ | |||
| 203 | +4x |
- #' A named list of the following elements:+ strata_vars <- names(strata_data) |
||
| 13 | -+ | |||
| 204 | +4x |
- #' * `df`+ checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte)) |
||
| 14 | -+ | |||
| 205 | +4x |
- #' * `difference_mean`+ assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars))) |
||
| 15 | +206 |
- #' * `ci_mean`+ } else {
|
||
| 16 | -+ | |||
| 207 | +1x |
- #' * `difference_sd`+ assert_valid_factor(strata_data, len = nrow(df_tte)) |
||
| 17 | -+ | |||
| 208 | +1x |
- #' * `difference_se`+ strata_vars <- "strata_data" |
||
| 18 | +209 |
- #' * `upper_agreement_limit`+ } |
||
| 19 | -+ | |||
| 210 | +5x |
- #' * `lower_agreement_limit`+ df_tte[strata_vars] <- strata_data |
||
| 20 | +211 |
- #' * `agreement_limit_se`+ } |
||
| 21 | +212 |
- #' * `upper_agreement_limit_ci`+ |
||
| 22 | -+ | |||
| 213 | +85x |
- #' * `lower_agreement_limit_ci`+ l_df <- split(df_tte, arm) |
||
| 23 | +214 |
- #' * `t_value`+ |
||
| 24 | -+ | |||
| 215 | +85x |
- #' * `n`+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
||
| 25 | +216 |
- #'+ # Hazard ratio and CI. |
||
| 26 | -+ | |||
| 217 | +79x |
- #' @examples+ result <- s_coxph_pairwise( |
||
| 27 | -+ | |||
| 218 | +79x |
- #' x <- seq(1, 60, 5)+ df = l_df[[2]], |
||
| 28 | -+ | |||
| 219 | +79x |
- #' y <- seq(5, 50, 4)+ .ref_group = l_df[[1]], |
||
| 29 | -+ | |||
| 220 | +79x |
- #'+ .in_ref_col = FALSE, |
||
| 30 | -+ | |||
| 221 | +79x |
- #' s_bland_altman(x, y, conf_level = 0.9)+ .var = "tte",+ |
+ ||
| 222 | +79x | +
+ is_event = "is_event",+ |
+ ||
| 223 | +79x | +
+ strata = strata_vars,+ |
+ ||
| 224 | +79x | +
+ control = control |
||
| 31 | +225 |
- #'+ ) |
||
| 32 | +226 |
- #' @export+ + |
+ ||
| 227 | +79x | +
+ df <- data.frame( |
||
| 33 | +228 |
- s_bland_altman <- function(x, y, conf_level = 0.95) {
+ # Dummy column needed downstream to create a nested header. |
||
| 34 | -7x | +229 | +79x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE)+ arm = " ", |
| 35 | -6x | +230 | +79x |
- checkmate::assert_numeric(y, len = length(x), any.missing = TRUE)+ n_tot = unname(as.numeric(result$n_tot)), |
| 36 | -5x | +231 | +79x |
- checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE)+ n_tot_events = unname(as.numeric(result$n_tot_events)), |
| 37 | -+ | |||
| 232 | +79x |
-
+ hr = unname(as.numeric(result$hr)), |
||
| 38 | -4x | +233 | +79x |
- alpha <- 1 - conf_level+ lcl = unname(result$hr_ci[1]), |
| 39 | -+ | |||
| 234 | +79x |
-
+ ucl = unname(result$hr_ci[2]), |
||
| 40 | -4x | +235 | +79x |
- ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length+ conf_level = control[["conf_level"]], |
| 41 | -4x | +236 | +79x |
- x <- x[ind]+ pval = as.numeric(result$pvalue), |
| 42 | -4x | +237 | +79x |
- y <- y[ind]+ pval_label = obj_label(result$pvalue), |
| 43 | -4x | +238 | +79x |
- n <- sum(ind) # number of 'observations'+ stringsAsFactors = FALSE |
| 44 | +239 |
-
+ ) |
||
| 45 | -4x | +|||
| 240 | +
- if (n == 0) {
+ } else if ( |
|||
| 46 | -! | +|||
| 241 | +6x |
- stop("there is no valid paired data")
+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
||
| 47 | -+ | |||
| 242 | +6x |
- }+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
||
| 48 | +243 |
-
+ ) {
|
||
| 49 | -4x | +244 | +6x |
- difference <- x - y # vector of differences+ df_tte_complete <- df_tte[stats::complete.cases(df_tte), ] |
| 50 | -4x | +245 | +6x |
- average <- (x + y) / 2 # vector of means+ df <- data.frame( |
| 51 | -4x | +|||
| 246 | +
- difference_mean <- mean(difference) # mean difference+ # Dummy column needed downstream to create a nested header. |
|||
| 52 | -4x | +247 | +6x |
- difference_sd <- sd(difference) # SD of differences+ arm = " ", |
| 53 | -4x | +248 | +6x |
- al <- qnorm(1 - alpha / 2) * difference_sd+ n_tot = nrow(df_tte_complete), |
| 54 | -4x | +249 | +6x |
- upper_agreement_limit <- difference_mean + al # agreement limits+ n_tot_events = sum(df_tte_complete$is_event), |
| 55 | -4x | -
- lower_agreement_limit <- difference_mean - al- |
- ||
| 56 | -+ | 250 | +6x |
-
+ hr = NA, |
| 57 | -4x | +251 | +6x |
- difference_se <- difference_sd / sqrt(n) # standard error of the mean+ lcl = NA, |
| 58 | -4x | +252 | +6x |
- al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit+ ucl = NA, |
| 59 | -4x | +253 | +6x |
- tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation+ conf_level = control[["conf_level"]], |
| 60 | -4x | +254 | +6x |
- difference_mean_ci <- difference_se * tvalue+ pval = NA, |
| 61 | -4x | +255 | +6x |
- al_ci <- al_se * tvalue+ pval_label = NA, |
| 62 | -4x | +256 | +6x |
- upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci)+ stringsAsFactors = FALSE |
| 63 | -4x | +|||
| 257 | +
- lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci)+ ) |
|||
| 64 | +258 |
-
+ } else {
|
||
| 65 | -4x | +|||
| 259 | +! |
- list(+ df <- data.frame( |
||
| 66 | -4x | +|||
| 260 | +
- df = data.frame(average, difference),+ # Dummy column needed downstream to create a nested header. |
|||
| 67 | -4x | +|||
| 261 | +! |
- difference_mean = difference_mean,+ arm = " ", |
||
| 68 | -4x | +|||
| 262 | +! |
- ci_mean = difference_mean + c(-1, 1) * difference_mean_ci,+ n_tot = 0L, |
||
| 69 | -4x | +|||
| 263 | +! |
- difference_sd = difference_sd,+ n_tot_events = 0L, |
||
| 70 | -4x | +|||
| 264 | +! |
- difference_se = difference_se,+ hr = NA, |
||
| 71 | -4x | +|||
| 265 | +! |
- upper_agreement_limit = upper_agreement_limit,+ lcl = NA, |
||
| 72 | -4x | +|||
| 266 | +! |
- lower_agreement_limit = lower_agreement_limit,+ ucl = NA, |
||
| 73 | -4x | +|||
| 267 | +! |
- agreement_limit_se = al_se,+ conf_level = control[["conf_level"]], |
||
| 74 | -4x | +|||
| 268 | +! |
- upper_agreement_limit_ci = upper_agreement_limit_ci,+ pval = NA, |
||
| 75 | -4x | +|||
| 269 | +! |
- lower_agreement_limit_ci = lower_agreement_limit_ci,+ pval_label = NA, |
||
| 76 | -4x | +|||
| 270 | +! |
- t_value = tvalue,+ stringsAsFactors = FALSE |
||
| 77 | -4x | +|||
| 271 | +
- n = n+ ) |
|||
| 78 | +272 |
- )+ } |
||
| 79 | +273 | ++ | + + | +|
| 274 | +85x | +
+ df+ |
+ ||
| 275 |
} |
|||
| 80 | +276 | |||
| 81 | +277 |
- #' Bland-Altman plot+ #' @describeIn h_survival_duration_subgroups Summarizes estimates of the treatment hazard ratio |
||
| 82 | +278 |
- #'+ #' across subgroups in a data frame. `variables` corresponds to the names of variables found in |
||
| 83 | +279 |
- #' @description `r lifecycle::badge("experimental")`
+ #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and |
||
| 84 | +280 |
- #'+ #' optionally `subgroups` and `strata`. `groups_lists` optionally specifies |
||
| 85 | +281 |
- #' Graphing function that produces a Bland-Altman plot.+ #' groupings for `subgroups` variables. |
||
| 86 | +282 |
#' |
||
| 87 | +283 |
- #' @inheritParams s_bland_altman+ #' @return |
||
| 88 | +284 |
- #'+ #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, |
||
| 89 | +285 |
- #' @return A `ggplot` Bland-Altman plot.+ #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 90 | +286 |
#' |
||
| 91 | +287 |
#' @examples |
||
| 92 | +288 |
- #' x <- seq(1, 60, 5)+ #' # Extract hazard ratio for multiple groups. |
||
| 93 | +289 |
- #' y <- seq(5, 50, 4)+ #' h_coxph_subgroups_df( |
||
| 94 | +290 |
- #'+ #' variables = list( |
||
| 95 | +291 |
- #' g_bland_altman(x = x, y = y, conf_level = 0.9)+ #' tte = "AVAL", |
||
| 96 | +292 |
- #'+ #' is_event = "is_event", |
||
| 97 | +293 |
- #' @export+ #' arm = "ARM", |
||
| 98 | +294 |
- #' @aliases bland_altman+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 99 | +295 |
- g_bland_altman <- function(x, y, conf_level = 0.95) {
+ #' ), |
||
| 100 | -1x | +|||
| 296 | +
- result_tem <- s_bland_altman(x, y, conf_level = conf_level)+ #' data = adtte_f |
|||
| 101 | -1x | +|||
| 297 | +
- xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1+ #' ) |
|||
| 102 | -1x | +|||
| 298 | +
- yrange <- diff(range(result_tem$df$difference))+ #' |
|||
| 103 | +299 |
-
+ #' # Define groupings of BMRKR2 levels. |
||
| 104 | -1x | +|||
| 300 | +
- p <- ggplot(result_tem$df) ++ #' h_coxph_subgroups_df( |
|||
| 105 | -1x | +|||
| 301 | +
- geom_point(aes(x = average, y = difference), color = "blue") ++ #' variables = list( |
|||
| 106 | -1x | +|||
| 302 | +
- geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) ++ #' tte = "AVAL", |
|||
| 107 | -1x | +|||
| 303 | +
- geom_hline(yintercept = 0, color = "blue", linetype = 2) ++ #' is_event = "is_event", |
|||
| 108 | -1x | +|||
| 304 | +
- geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) ++ #' arm = "ARM", |
|||
| 109 | -1x | +|||
| 305 | +
- geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) ++ #' subgroups = c("SEX", "BMRKR2")
|
|||
| 110 | -1x | +|||
| 306 | +
- annotate(+ #' ), |
|||
| 111 | -1x | +|||
| 307 | +
- "text",+ #' data = adtte_f, |
|||
| 112 | -1x | +|||
| 308 | +
- x = xpos,+ #' groups_lists = list( |
|||
| 113 | -1x | +|||
| 309 | +
- y = result_tem$lower_agreement_limit + 0.03 * yrange,+ #' BMRKR2 = list( |
|||
| 114 | -1x | +|||
| 310 | +
- label = "lower limits of agreement",+ #' "low" = "LOW", |
|||
| 115 | -1x | +|||
| 311 | +
- color = "red"+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 116 | +312 |
- ) ++ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 117 | -1x | +|||
| 313 | +
- annotate(+ #' ) |
|||
| 118 | -1x | +|||
| 314 | +
- "text",+ #' ) |
|||
| 119 | -1x | +|||
| 315 | +
- x = xpos,+ #' ) |
|||
| 120 | -1x | +|||
| 316 | +
- y = result_tem$upper_agreement_limit + 0.03 * yrange,+ #' |
|||
| 121 | -1x | +|||
| 317 | +
- label = "upper limits of agreement",+ #' # Extract hazard ratio for multiple groups with stratification factors. |
|||
| 122 | -1x | +|||
| 318 | +
- color = "red"+ #' h_coxph_subgroups_df( |
|||
| 123 | +319 |
- ) ++ #' variables = list( |
||
| 124 | -1x | +|||
| 320 | +
- annotate(+ #' tte = "AVAL", |
|||
| 125 | -1x | +|||
| 321 | +
- "text",+ #' is_event = "is_event", |
|||
| 126 | -1x | +|||
| 322 | +
- x = xpos,+ #' arm = "ARM", |
|||
| 127 | -1x | +|||
| 323 | +
- y = result_tem$difference_mean + 0.03 * yrange,+ #' subgroups = c("SEX", "BMRKR2"),
|
|||
| 128 | -1x | +|||
| 324 | +
- label = "mean of difference between two measures",+ #' strata = c("STRATA1", "STRATA2")
|
|||
| 129 | -1x | +|||
| 325 | +
- color = "blue"+ #' ), |
|||
| 130 | +326 |
- ) ++ #' data = adtte_f |
||
| 131 | -1x | +|||
| 327 | +
- annotate(+ #' ) |
|||
| 132 | -1x | +|||
| 328 | +
- "text",+ #' |
|||
| 133 | -1x | +|||
| 329 | +
- x = xpos,+ #' @export |
|||
| 134 | -1x | +|||
| 330 | +
- y = result_tem$lower_agreement_limit - 0.03 * yrange,+ h_coxph_subgroups_df <- function(variables, |
|||
| 135 | -1x | +|||
| 331 | +
- label = sprintf("%.2f", result_tem$lower_agreement_limit),
+ data, |
|||
| 136 | -1x | +|||
| 332 | +
- color = "red"+ groups_lists = list(), |
|||
| 137 | +333 |
- ) ++ control = control_coxph(), |
||
| 138 | -1x | +|||
| 334 | +
- annotate(+ label_all = "All Patients") {
|
|||
| 139 | -1x | +335 | +17x |
- "text",+ if ("strat" %in% names(variables)) {
|
| 140 | -1x | +|||
| 336 | +! |
- x = xpos,+ warning( |
||
| 141 | -1x | +|||
| 337 | +! |
- y = result_tem$upper_agreement_limit - 0.03 * yrange,+ "Warning: the `strat` element name of the `variables` list argument to `h_coxph_subgroups_df() ", |
||
| 142 | -1x | +|||
| 338 | +! |
- label = sprintf("%.2f", result_tem$upper_agreement_limit),
+ "was deprecated in tern 0.9.4.\n ", |
||
| 143 | -1x | +|||
| 339 | +! |
- color = "red"+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 144 | +340 |
- ) ++ ) |
||
| 145 | -1x | +|||
| 341 | +! |
- annotate(+ variables[["strata"]] <- variables[["strat"]]+ |
+ ||
| 342 | ++ |
+ }+ |
+ ||
| 343 | ++ | + | ||
| 146 | -1x | +344 | +17x |
- "text",+ checkmate::assert_character(variables$tte) |
| 147 | -1x | +345 | +17x |
- x = xpos,+ checkmate::assert_character(variables$is_event) |
| 148 | -1x | +346 | +17x |
- y = result_tem$difference_mean - 0.03 * yrange,+ checkmate::assert_character(variables$arm) |
| 149 | -1x | +347 | +17x |
- label = sprintf("%.2f", result_tem$difference_meanm),
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 150 | -1x | +348 | +17x |
- color = "blue"+ checkmate::assert_character(variables$strata, null.ok = TRUE) |
| 151 | -+ | |||
| 349 | +17x |
- ) ++ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
||
| 152 | -1x | +350 | +17x |
- xlab("Average of two measures") +
+ assert_df_with_variables(data, variables) |
| 153 | -1x | +351 | +17x |
- ylab("Difference between two measures")
+ checkmate::assert_string(label_all) |
| 154 | +352 | |||
| 353 | ++ |
+ # Add All Patients.+ |
+ ||
| 155 | -1x | +354 | +17x |
- return(p)+ result_all <- h_coxph_df( |
| 156 | -+ | |||
| 355 | +17x |
- }+ tte = data[[variables$tte]], |
| 1 | -+ | |||
| 356 | +17x |
- #' Tabulate biomarker effects on binary response by subgroup+ is_event = data[[variables$is_event]], |
||
| 2 | -+ | |||
| 357 | +17x |
- #'+ arm = data[[variables$arm]], |
||
| 3 | -+ | |||
| 358 | +17x |
- #' @description `r lifecycle::badge("stable")`
+ strata_data = if (is.null(variables$strata)) NULL else data[variables$strata], |
||
| 4 | -+ | |||
| 359 | +17x |
- #'+ control = control |
||
| 5 | +360 |
- #' The [tabulate_rsp_biomarkers()] function creates a layout element to tabulate the estimated biomarker effects on a+ ) |
||
| 6 | -+ | |||
| 361 | +17x |
- #' binary response endpoint across subgroups, returning statistics including response rate and odds ratio for each+ result_all$subgroup <- label_all |
||
| 7 | -+ | |||
| 362 | +17x |
- #' population subgroup. The table is created from `df`, a list of data frames returned by [extract_rsp_biomarkers()],+ result_all$var <- "ALL" |
||
| 8 | -+ | |||
| 363 | +17x |
- #' with the statistics to include specified via the `vars` parameter.+ result_all$var_label <- label_all |
||
| 9 | -+ | |||
| 364 | +17x |
- #'+ result_all$row_type <- "content" |
||
| 10 | +365 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ |
||
| 11 | +366 |
- #'+ # Add Subgroups. |
||
| 12 | -+ | |||
| 367 | +17x |
- #' @inheritParams argument_convention+ if (is.null(variables$subgroups)) {
|
||
| 13 | -+ | |||
| 368 | +3x |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ result_all |
||
| 14 | +369 |
- #' [extract_rsp_biomarkers()].+ } else {
|
||
| 15 | -+ | |||
| 370 | +14x |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 16 | +371 |
- #' * `n_tot`: Total number of patients per group.+ |
||
| 17 | -+ | |||
| 372 | +14x |
- #' * `n_rsp`: Total number of responses per group.+ l_result <- lapply(l_data, function(grp) {
|
||
| 18 | -+ | |||
| 373 | +64x |
- #' * `prop`: Total response proportion per group.+ result <- h_coxph_df( |
||
| 19 | -+ | |||
| 374 | +64x |
- #' * `or`: Odds ratio.+ tte = grp$df[[variables$tte]], |
||
| 20 | -+ | |||
| 375 | +64x |
- #' * `ci`: Confidence interval of odds ratio.+ is_event = grp$df[[variables$is_event]], |
||
| 21 | -+ | |||
| 376 | +64x |
- #' * `pval`: p-value of the effect.+ arm = grp$df[[variables$arm]], |
||
| 22 | -+ | |||
| 377 | +64x |
- #' Note, the statistics `n_tot`, `or` and `ci` are required.+ strata_data = if (is.null(variables$strata)) NULL else grp$df[variables$strata], |
||
| 23 | -+ | |||
| 378 | +64x |
- #'+ control = control |
||
| 24 | +379 |
- #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup.+ ) |
||
| 25 | -+ | |||
| 380 | +64x |
- #'+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
||
| 26 | -+ | |||
| 381 | +64x |
- #' @details These functions create a layout starting from a data frame which contains+ cbind(result, result_labels) |
||
| 27 | +382 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ }) |
||
| 28 | +383 |
- #'+ |
||
| 29 | -+ | |||
| 384 | +14x |
- #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+ ||
| 385 | +14x | +
+ result_subgroups$row_type <- "analysis" |
||
| 30 | +386 |
- #' not start from an input layout `lyt`. This is because internally the table is+ + |
+ ||
| 387 | +14x | +
+ rbind(+ |
+ ||
| 388 | +14x | +
+ result_all,+ |
+ ||
| 389 | +14x | +
+ result_subgroups |
||
| 31 | +390 |
- #' created by combining multiple subtables.+ ) |
||
| 32 | +391 |
- #'+ } |
||
| 33 | +392 |
- #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].+ } |
||
| 34 | +393 |
- #'+ |
||
| 35 | +394 |
- #' @examples+ #' Split data frame by subgroups |
||
| 36 | +395 |
- #' library(dplyr)+ #' |
||
| 37 | +396 |
- #' library(forcats)+ #' @description `r lifecycle::badge("stable")`
|
||
| 38 | +397 |
#' |
||
| 39 | +398 |
- #' adrs <- tern_ex_adrs+ #' Split a data frame into a non-nested list of subsets. |
||
| 40 | +399 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' |
||
| 41 | +400 |
- #'+ #' @inheritParams argument_convention |
||
| 42 | +401 |
- #' adrs_f <- adrs %>%+ #' @inheritParams survival_duration_subgroups |
||
| 43 | +402 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' @param data (`data.frame`)\cr dataset to split. |
||
| 44 | +403 |
- #' mutate(rsp = AVALC == "CR")+ #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets. |
||
| 45 | +404 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' Unused levels not present in `data` are dropped. Note that the order in this vector |
||
| 46 | +405 |
- #'+ #' determines the order in the downstream table. |
||
| 47 | +406 |
- #' df <- extract_rsp_biomarkers(+ #' |
||
| 48 | +407 |
- #' variables = list(+ #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`). |
||
| 49 | +408 |
- #' rsp = "rsp",+ #' |
||
| 50 | +409 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @details Main functionality is to prepare data for use in forest plot layouts. |
||
| 51 | +410 |
- #' covariates = "SEX",+ #' |
||
| 52 | +411 |
- #' subgroups = "BMRKR2"+ #' @examples |
||
| 53 | +412 |
- #' ),+ #' df <- data.frame( |
||
| 54 | +413 |
- #' data = adrs_f+ #' x = c(1:5), |
||
| 55 | +414 |
- #' )+ #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
|
||
| 56 | +415 |
- #'+ #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
|
||
| 57 | +416 |
- #' \donttest{
+ #' ) |
||
| 58 | +417 |
- #' ## Table with default columns.+ #' formatters::var_labels(df) <- paste("label for", names(df))
|
||
| 59 | +418 |
- #' tabulate_rsp_biomarkers(df)+ #' |
||
| 60 | +419 |
- #'+ #' h_split_by_subgroups( |
||
| 61 | +420 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ #' data = df, |
||
| 62 | +421 |
- #' tab <- tabulate_rsp_biomarkers(+ #' subgroups = c("y", "z")
|
||
| 63 | +422 |
- #' df = df,+ #' ) |
||
| 64 | +423 |
- #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
+ #' |
||
| 65 | +424 |
- #' )+ #' h_split_by_subgroups( |
||
| 66 | +425 |
- #'+ #' data = df, |
||
| 67 | +426 |
- #' ## Finally produce the forest plot.+ #' subgroups = c("y", "z"),
|
||
| 68 | +427 |
- #' g_forest(tab, xlim = c(0.7, 1.4))+ #' groups_lists = list( |
||
| 69 | +428 |
- #' }+ #' y = list("AB" = c("A", "B"), "C" = "C")
|
||
| 70 | +429 |
- #'+ #' ) |
||
| 71 | +430 |
- #' @export+ #' ) |
||
| 72 | +431 |
- #' @name response_biomarkers_subgroups+ #' |
||
| 73 | +432 |
- tabulate_rsp_biomarkers <- function(df,+ #' @export |
||
| 74 | +433 |
- vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ h_split_by_subgroups <- function(data, |
||
| 75 | +434 |
- na_str = default_na_str(),+ subgroups, |
||
| 76 | +435 |
- .indent_mods = 0L) {
+ groups_lists = list()) {
|
||
| 77 | -4x | +436 | +66x |
- checkmate::assert_data_frame(df)+ checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE) |
| 78 | -4x | +437 | +66x |
- checkmate::assert_character(df$biomarker)+ checkmate::assert_list(groups_lists, names = "named") |
| 79 | -4x | +438 | +66x |
- checkmate::assert_character(df$biomarker_label)+ checkmate::assert_subset(names(groups_lists), subgroups) |
| 80 | -4x | +439 | +66x |
- checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
+ assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups))) |
| 81 | +440 | |||
| 82 | -+ | |||
| 441 | +66x |
- # Create "ci" column from "lcl" and "ucl"+ data_labels <- unname(formatters::var_labels(data)) |
||
| 83 | -4x | +442 | +66x |
- df$ci <- combine_vectors(df$lcl, df$ucl)+ df_subgroups <- data[, subgroups, drop = FALSE]+ |
+
| 443 | +66x | +
+ subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE) |
||
| 84 | +444 | |||
| 85 | -4x | +445 | +66x |
- df_subs <- split(df, f = df$biomarker)+ l_labels <- Map(function(grp_i, name_i) {
|
| 86 | -4x | +446 | +120x |
- tabs <- lapply(df_subs, FUN = function(df_sub) {
+ existing_levels <- levels(droplevels(grp_i)) |
| 87 | -7x | +447 | +120x |
- tab_sub <- h_tab_rsp_one_biomarker(+ grp_levels <- if (name_i %in% names(groups_lists)) {
|
| 88 | -7x | +|||
| 448 | +
- df = df_sub,+ # For this variable groupings are defined. We check which groups are contained in the data. |
|||
| 89 | -7x | +449 | +11x |
- vars = vars,+ group_list_i <- groups_lists[[name_i]] |
| 90 | -7x | +450 | +11x |
- na_str = na_str,+ group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE) |
| 91 | -7x | +451 | +11x |
- .indent_mods = .indent_mods+ names(which(group_has_levels)) |
| 92 | +452 |
- )+ } else {
+ |
+ ||
| 453 | +109x | +
+ existing_levels |
||
| 93 | +454 |
- # Insert label row as first row in table.+ } |
||
| 94 | -7x | +455 | +120x |
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ df_labels <- data.frame( |
| 95 | -7x | +456 | +120x |
- tab_sub+ subgroup = grp_levels,+ |
+
| 457 | +120x | +
+ var = name_i,+ |
+ ||
| 458 | +120x | +
+ var_label = unname(subgroup_labels[name_i]),+ |
+ ||
| 459 | +120x | +
+ stringsAsFactors = FALSE # Rationale is that subgroups may not be unique. |
||
| 96 | +460 |
- })+ ) |
||
| 97 | -4x | +461 | +66x |
- result <- do.call(rbind, tabs)+ }, df_subgroups, names(df_subgroups)) |
| 98 | +462 | |||
| 99 | -4x | +|||
| 463 | +
- n_id <- grep("n_tot", vars)
+ # Create a data frame with one row per subgroup. |
|||
| 100 | -4x | +464 | +66x |
- or_id <- match("or", vars)
+ df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE)) |
| 101 | -4x | +465 | +66x |
- ci_id <- match("ci", vars)
+ row_label <- paste0(df_labels$var, ".", df_labels$subgroup) |
| 102 | -4x | +466 | +66x |
- structure(+ row_split_var <- factor(row_label, levels = row_label) |
| 103 | -4x | +|||
| 467 | +
- result,+ |
|||
| 104 | -4x | +|||
| 468 | +
- forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
+ # Create a list of data subsets. |
|||
| 105 | -4x | +469 | +66x |
- col_x = or_id,+ lapply(split(df_labels, row_split_var), function(row_i) {
|
| 106 | -4x | +470 | +294x |
- col_ci = ci_id,+ which_row <- if (row_i$var %in% names(groups_lists)) {
|
| 107 | -4x | +471 | +31x |
- col_symbol_size = n_id+ data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]] |
| 108 | +472 |
- )+ } else {
|
||
| 109 | -+ | |||
| 473 | +263x |
- }+ data[[row_i$var]] == row_i$subgroup |
||
| 110 | +474 |
-
+ } |
||
| 111 | -+ | |||
| 475 | +294x |
- #' Prepare response data estimates for multiple biomarkers in a single data frame+ df <- data[which_row, ] |
||
| 112 | -+ | |||
| 476 | +294x |
- #'+ rownames(df) <- NULL |
||
| 113 | -+ | |||
| 477 | +294x |
- #' @description `r lifecycle::badge("stable")`
+ formatters::var_labels(df) <- data_labels |
||
| 114 | +478 |
- #'+ |
||
| 115 | -+ | |||
| 479 | +294x |
- #' Prepares estimates for number of responses, patients and overall response rate,+ list( |
||
| 116 | -+ | |||
| 480 | +294x |
- #' as well as odds ratio estimates, confidence intervals and p-values,+ df = df, |
||
| 117 | -+ | |||
| 481 | +294x |
- #' for multiple biomarkers across population subgroups in a single data frame.+ df_labels = data.frame(row_i, row.names = NULL) |
||
| 118 | +482 |
- #' `variables` corresponds to the names of variables found in `data`, passed as a+ ) |
||
| 119 | +483 |
- #' named list and requires elements `rsp` and `biomarkers` (vector of continuous+ }) |
||
| 120 | +484 |
- #' biomarker variables) and optionally `covariates`, `subgroups` and `strata`.+ } |
| 121 | +1 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' Count occurrences by grade |
||
| 122 | +2 |
#' |
||
| 123 | +3 |
- #' @inheritParams argument_convention+ #' @description `r lifecycle::badge("stable")`
|
||
| 124 | +4 |
- #' @inheritParams response_subgroups+ #' |
||
| 125 | +5 |
- #' @param control (named `list`)\cr controls for the response definition and the+ #' The analyze function [count_occurrences_by_grade()] creates a layout element to calculate occurrence counts by grade. |
||
| 126 | +6 |
- #' confidence level produced by [control_logistic()].+ #' |
||
| 127 | +7 |
- #'+ #' This function analyzes primary analysis variable `var` which indicates toxicity grades. The `id` variable |
||
| 128 | +8 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`,+ #' is used to indicate unique subject identifiers (defaults to `USUBJID`). The user can also supply a list of |
||
| 129 | +9 |
- #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ #' custom groups of grades to analyze via the `grade_groups` parameter. The `remove_single` argument will |
||
| 130 | +10 |
- #' `var_label`, and `row_type`.+ #' remove single grades from the analysis so that *only* grade groups are analyzed. |
||
| 131 | +11 |
#' |
||
| 132 | +12 |
- #' @note You can also specify a continuous variable in `rsp` and then use the+ #' If there are multiple grades recorded for one patient only the highest grade level is counted. |
||
| 133 | +13 |
- #' `response_definition` control to convert that internally to a logical+ #' |
||
| 134 | +14 |
- #' variable reflecting binary response.+ #' The summarize function [summarize_occurrences_by_grade()] performs the same function as |
||
| 135 | +15 |
- #'+ #' [count_occurrences_by_grade()] except it creates content rows, not data rows, to summarize the current table |
||
| 136 | +16 |
- #' @seealso [h_logistic_mult_cont_df()] which is used internally.+ #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
||
| 137 | +17 |
- #'+ #' occurred. |
||
| 138 | +18 |
- #' @examples+ #' |
||
| 139 | +19 |
- #' library(dplyr)+ #' @inheritParams count_occurrences |
||
| 140 | +20 |
- #' library(forcats)+ #' @inheritParams argument_convention |
||
| 141 | +21 |
- #'+ #' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades. |
||
| 142 | +22 |
- #' adrs <- tern_ex_adrs+ #' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups |
||
| 143 | +23 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' in the the output list; in this case only the grade groups names will be included in the output. If |
||
| 144 | +24 |
- #'+ #' `only_grade_groups` is set to `TRUE` this argument is ignored. |
||
| 145 | +25 |
- #' adrs_f <- adrs %>%+ #' @param only_grade_groups (`flag`)\cr whether only the specified grade groups should be |
||
| 146 | +26 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' included, with individual grade rows removed (`TRUE`), or all grades and grade groups |
||
| 147 | +27 |
- #' mutate(rsp = AVALC == "CR")+ #' should be displayed (`FALSE`). |
||
| 148 | +28 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 149 | +29 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ #' |
||
| 150 | +30 |
- #' # in logistic regression models with one covariate `RACE`. The subgroups+ #' Options are: ``r shQuote(get_stats("count_occurrences_by_grade"))``
|
||
| 151 | +31 |
- #' # are defined by the levels of `BMRKR2`.+ #' |
||
| 152 | +32 |
- #' df <- extract_rsp_biomarkers(+ #' @seealso Relevant helper function [h_append_grade_groups()]. |
||
| 153 | +33 |
- #' variables = list(+ #' |
||
| 154 | +34 |
- #' rsp = "rsp",+ #' @name count_occurrences_by_grade |
||
| 155 | +35 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @order 1 |
||
| 156 | +36 |
- #' covariates = "SEX",+ NULL |
||
| 157 | +37 |
- #' subgroups = "BMRKR2"+ |
||
| 158 | +38 |
- #' ),+ #' Helper function for `s_count_occurrences_by_grade()` |
||
| 159 | +39 |
- #' data = adrs_f+ #' |
||
| 160 | +40 |
- #' )+ #' @description `r lifecycle::badge("stable")`
|
||
| 161 | +41 |
- #' df+ #' |
||
| 162 | +42 |
- #'+ #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with |
||
| 163 | +43 |
- #' # Here we group the levels of `BMRKR2` manually, and we add a stratification+ #' individual grade frequencies. The order of the final result follows the order of `grade_groups`. |
||
| 164 | +44 |
- #' # variable `STRATA1`. We also here use a continuous variable `EOSDY`+ #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to |
||
| 165 | +45 |
- #' # which is then binarized internally (response is defined as this variable+ #' the end. Grade groups names must be unique. |
||
| 166 | +46 |
- #' # being larger than 750).+ #' |
||
| 167 | +47 |
- #' df_grouped <- extract_rsp_biomarkers(+ #' @inheritParams count_occurrences_by_grade |
||
| 168 | +48 |
- #' variables = list(+ #' @param refs (named `list` of `numeric`)\cr named list where each name corresponds to a reference grade level |
||
| 169 | +49 |
- #' rsp = "EOSDY",+ #' and each entry represents a count. |
||
| 170 | +50 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' |
||
| 171 | +51 |
- #' covariates = "SEX",+ #' @return Formatted list of grade groupings. |
||
| 172 | +52 |
- #' subgroups = "BMRKR2",+ #' |
||
| 173 | +53 |
- #' strata = "STRATA1"+ #' @examples |
||
| 174 | +54 |
- #' ),+ #' h_append_grade_groups( |
||
| 175 | +55 |
- #' data = adrs_f,+ #' list( |
||
| 176 | +56 |
- #' groups_lists = list(+ #' "Any Grade" = as.character(1:5), |
||
| 177 | +57 |
- #' BMRKR2 = list(+ #' "Grade 1-2" = c("1", "2"),
|
||
| 178 | +58 |
- #' "low" = "LOW",+ #' "Grade 3-4" = c("3", "4")
|
||
| 179 | +59 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' ), |
||
| 180 | +60 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 181 | +61 |
- #' )+ #' ) |
||
| 182 | +62 |
- #' ),+ #' |
||
| 183 | +63 |
- #' control = control_logistic(+ #' h_append_grade_groups( |
||
| 184 | +64 |
- #' response_definition = "I(response > 750)"+ #' list( |
||
| 185 | +65 |
- #' )+ #' "Any Grade" = as.character(5:1), |
||
| 186 | +66 |
- #' )+ #' "Grade A" = "5", |
||
| 187 | +67 |
- #' df_grouped+ #' "Grade B" = c("4", "3")
|
||
| 188 | +68 |
- #'+ #' ), |
||
| 189 | +69 |
- #' @export+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 190 | +70 |
- extract_rsp_biomarkers <- function(variables,+ #' ) |
||
| 191 | +71 |
- data,+ #' |
||
| 192 | +72 |
- groups_lists = list(),+ #' h_append_grade_groups( |
||
| 193 | +73 |
- control = control_logistic(),+ #' list( |
||
| 194 | +74 |
- label_all = "All Patients") {
- |
- ||
| 195 | -5x | -
- if ("strat" %in% names(variables)) {
+ #' "Any Grade" = as.character(1:5), |
||
| 196 | -! | +|||
| 75 | +
- warning(+ #' "Grade 1-2" = c("1", "2"),
|
|||
| 197 | -! | +|||
| 76 | +
- "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_biomarkers() ",+ #' "Grade 3-4" = c("3", "4")
|
|||
| 198 | -! | +|||
| 77 | +
- "was deprecated in tern 0.9.4.\n ",+ #' ), |
|||
| 199 | -! | +|||
| 78 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' list("1" = 10, "2" = 5, "3" = 0)
|
|||
| 200 | +79 |
- )+ #' ) |
||
| 201 | -! | +|||
| 80 | +
- variables[["strata"]] <- variables[["strat"]]+ #' |
|||
| 202 | +81 |
- }+ #' @export |
||
| 203 | +82 |
-
+ h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only_grade_groups = FALSE) {
|
||
| 204 | -5x | +83 | +32x |
- assert_list_of_variables(variables)+ checkmate::assert_list(grade_groups) |
| 205 | -5x | +84 | +32x |
- checkmate::assert_string(variables$rsp)+ checkmate::assert_list(refs) |
| 206 | -5x | +85 | +32x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ refs_orig <- refs |
| 207 | -5x | +86 | +32x |
- checkmate::assert_string(label_all)+ elements <- unique(unlist(grade_groups)) |
| 208 | +87 | |||
| 209 | +88 |
- # Start with all patients.+ ### compute sums in groups |
||
| 210 | -5x | +89 | +32x |
- result_all <- h_logistic_mult_cont_df(+ grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i])) |
| 211 | -5x | +90 | +32x |
- variables = variables,+ if (!checkmate::test_subset(elements, names(refs))) {
|
| 212 | -5x | +91 | +2x |
- data = data,+ padding_el <- setdiff(elements, names(refs)) |
| 213 | -5x | +92 | +2x |
- control = control+ refs[padding_el] <- 0 |
| 214 | +93 |
- )- |
- ||
| 215 | -5x | -
- result_all$subgroup <- label_all- |
- ||
| 216 | -5x | -
- result_all$var <- "ALL"- |
- ||
| 217 | -5x | -
- result_all$var_label <- label_all+ } |
||
| 218 | -5x | +94 | +32x |
- result_all$row_type <- "content"+ result <- c(grp_sum, refs) |
| 219 | -5x | +|||
| 95 | +
- if (is.null(variables$subgroups)) {
+
|
|||
| 220 | +96 |
- # Only return result for all patients.+ ### order result while keeping grade_groups's ordering |
||
| 221 | -1x | +97 | +32x |
- result_all+ ordr <- grade_groups |
| 222 | +98 |
- } else {
+
|
||
| 223 | +99 |
- # Add subgroups results.- |
- ||
| 224 | -4x | -
- l_data <- h_split_by_subgroups(- |
- ||
| 225 | -4x | -
- data,+ # elements of any-grade group (if any) will be moved to the end |
||
| 226 | -4x | +100 | +32x |
- variables$subgroups,+ is_any <- sapply(grade_groups, setequal, y = names(refs)) |
| 227 | -4x | +101 | +32x |
- groups_lists = groups_lists+ ordr[is_any] <- list(character(0)) # hide elements under any-grade group |
| 228 | +102 |
- )- |
- ||
| 229 | -4x | -
- l_result <- lapply(l_data, function(grp) {
+
|
||
| 230 | -20x | +|||
| 103 | +
- result <- h_logistic_mult_cont_df(+ # groups-elements combined sequence |
|||
| 231 | -20x | +104 | +32x |
- variables = variables,+ ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE) |
| 232 | -20x | +105 | +32x |
- data = grp$df,+ ordr <- ordr[!duplicated(ordr)] |
| 233 | -20x | +|||
| 106 | +
- control = control+ |
|||
| 234 | +107 |
- )+ # append remaining elements (if any) |
||
| 235 | -20x | +108 | +32x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group |
| 236 | -20x | +109 | +32x |
- cbind(result, result_labels)+ ordr <- union(ordr, names(refs)) # from refs |
| 237 | +110 |
- })+ |
||
| 238 | -4x | +|||
| 111 | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ # remove elements of single-element groups, if any |
|||
| 239 | -4x | +112 | +32x |
- result_subgroups$row_type <- "analysis"+ if (only_grade_groups) {
|
| 240 | -4x | +113 | +3x |
- rbind(+ ordr <- intersect(ordr, names(grade_groups)) |
| 241 | -4x | +114 | +29x |
- result_all,+ } else if (remove_single) {
|
| 242 | -4x | +115 | +29x |
- result_subgroups+ is_single <- sapply(grade_groups, length) == 1L |
| 243 | -+ | |||
| 116 | +29x |
- )+ ordr <- setdiff(ordr, unlist(grade_groups[is_single])) |
||
| 244 | +117 |
} |
||
| 245 | +118 |
- }+ |
| 1 | +119 |
- #' Multivariate logistic regression table+ # apply the order |
||
| 2 | -+ | |||
| 120 | +32x |
- #'+ result <- result[ordr] |
||
| 3 | +121 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | +122 |
- #'+ # remove groups without any elements in the original refs |
||
| 5 | +123 |
- #' Layout-creating function which summarizes a logistic variable regression for binary outcome with+ # note: it's OK if groups have 0 value |
||
| 6 | -+ | |||
| 124 | +32x |
- #' categorical/continuous covariates in model statement. For each covariate category (if categorical)+ keep_grp <- vapply(grade_groups, function(x, rf) {
|
||
| 7 | -+ | |||
| 125 | +64x |
- #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and+ any(x %in% rf) |
||
| 8 | -+ | |||
| 126 | +32x |
- #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate+ }, rf = names(refs_orig), logical(1)) |
||
| 9 | +127 |
- #' category or specified values and corresponding Wald confidence intervals as default but allow user+ |
||
| 10 | -+ | |||
| 128 | +32x |
- #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis+ keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp] |
||
| 11 | -+ | |||
| 129 | +32x |
- #' that covariate has no effect on response in model containing all specified covariates.+ result <- result[keep_el] |
||
| 12 | +130 |
- #' Allow option to include one two-way interaction and present similar output for+ |
||
| 13 | -+ | |||
| 131 | +32x |
- #' each interaction degree of freedom.+ result |
||
| 14 | +132 |
- #'+ } |
||
| 15 | +133 |
- #' @inheritParams argument_convention+ |
||
| 16 | +134 |
- #' @param drop_and_remove_str (`string`)\cr string to be dropped and removed.+ #' @describeIn count_occurrences_by_grade Statistics function which counts the |
||
| 17 | +135 |
- #'+ #' number of patients by highest grade. |
||
| 18 | +136 |
- #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' |
||
| 19 | +137 |
- #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout.+ #' @return |
||
| 20 | +138 |
- #'+ #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or |
||
| 21 | +139 |
- #' @note For the formula, the variable names need to be standard `data.frame` column names without+ #' grade level grouping. |
||
| 22 | +140 |
- #' special characters.+ #' |
||
| 23 | +141 |
- #'+ #' @examples |
||
| 24 | +142 |
- #' @examples+ #' s_count_occurrences_by_grade( |
||
| 25 | +143 |
- #' library(dplyr)+ #' df, |
||
| 26 | +144 |
- #' library(broom)+ #' .N_col = 10L, |
||
| 27 | +145 |
- #'+ #' .var = "AETOXGR", |
||
| 28 | +146 |
- #' adrs_f <- tern_ex_adrs %>%+ #' id = "USUBJID", |
||
| 29 | +147 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 30 | +148 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' ) |
||
| 31 | +149 |
- #' mutate(+ #' |
||
| 32 | +150 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' @export |
||
| 33 | +151 |
- #' RACE = factor(RACE),+ s_count_occurrences_by_grade <- function(df, |
||
| 34 | +152 |
- #' SEX = factor(SEX)+ .var, |
||
| 35 | +153 |
- #' )+ .N_row, # nolint |
||
| 36 | +154 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ .N_col, # nolint |
||
| 37 | +155 |
- #' mod1 <- fit_logistic(+ id = "USUBJID", |
||
| 38 | +156 |
- #' data = adrs_f,+ grade_groups = list(), |
||
| 39 | +157 |
- #' variables = list(+ remove_single = TRUE, |
||
| 40 | +158 |
- #' response = "Response",+ only_grade_groups = FALSE, |
||
| 41 | +159 |
- #' arm = "ARMCD",+ denom = c("N_col", "n", "N_row"),
|
||
| 42 | +160 |
- #' covariates = c("AGE", "RACE")
+ labelstr = "") {
|
||
| 43 | -+ | |||
| 161 | +75x |
- #' )+ assert_valid_factor(df[[.var]]) |
||
| 44 | -+ | |||
| 162 | +75x |
- #' )+ assert_df_with_variables(df, list(grade = .var, id = id)) |
||
| 45 | +163 |
- #' mod2 <- fit_logistic(+ |
||
| 46 | -+ | |||
| 164 | +75x |
- #' data = adrs_f,+ denom <- match.arg(denom) %>% |
||
| 47 | -+ | |||
| 165 | +75x |
- #' variables = list(+ switch( |
||
| 48 | -+ | |||
| 166 | +75x |
- #' response = "Response",+ n = nlevels(factor(df[[id]])), |
||
| 49 | -+ | |||
| 167 | +75x |
- #' arm = "ARMCD",+ N_row = .N_row, |
||
| 50 | -+ | |||
| 168 | +75x |
- #' covariates = c("AGE", "RACE"),
+ N_col = .N_col |
||
| 51 | +169 |
- #' interaction = "AGE"+ ) |
||
| 52 | +170 |
- #' )+ |
||
| 53 | -+ | |||
| 171 | +75x |
- #' )+ if (nrow(df) < 1) {
|
||
| 54 | -+ | |||
| 172 | +5x |
- #'+ grade_levels <- levels(df[[.var]]) |
||
| 55 | -+ | |||
| 173 | +5x |
- #' df <- tidy(mod1, conf_level = 0.99)+ l_count <- as.list(rep(0, length(grade_levels))) |
||
| 56 | -+ | |||
| 174 | +5x |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ names(l_count) <- grade_levels |
||
| 57 | +175 |
- #'+ } else {
|
||
| 58 | -+ | |||
| 176 | +70x |
- #' # flagging empty strings with "_"+ if (isTRUE(is.factor(df[[id]]))) {
|
||
| 59 | -+ | |||
| 177 | +! |
- #' df <- df_explicit_na(df, na_level = "_")+ assert_valid_factor(df[[id]], any.missing = FALSE) |
||
| 60 | +178 |
- #' df2 <- df_explicit_na(df2, na_level = "_")+ } else {
|
||
| 61 | -+ | |||
| 179 | +70x |
- #'+ checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE) |
||
| 62 | +180 |
- #' result1 <- basic_table() %>%+ } |
||
| 63 | -+ | |||
| 181 | +70x |
- #' summarize_logistic(+ checkmate::assert_count(.N_col) |
||
| 64 | +182 |
- #' conf_level = 0.95,+ |
||
| 65 | -+ | |||
| 183 | +70x |
- #' drop_and_remove_str = "_"+ id <- df[[id]] |
||
| 66 | -+ | |||
| 184 | +70x |
- #' ) %>%+ grade <- df[[.var]] |
||
| 67 | +185 |
- #' build_table(df = df)+ |
||
| 68 | -+ | |||
| 186 | +70x |
- #' result1+ if (!is.ordered(grade)) {
|
||
| 69 | -+ | |||
| 187 | +70x |
- #'+ grade_lbl <- obj_label(grade) |
||
| 70 | -+ | |||
| 188 | +70x |
- #' result2 <- basic_table() %>%+ lvls <- levels(grade) |
||
| 71 | -+ | |||
| 189 | +70x |
- #' summarize_logistic(+ if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
|
||
| 72 | -+ | |||
| 190 | +69x |
- #' conf_level = 0.95,+ lvl_ord <- lvls |
||
| 73 | +191 |
- #' drop_and_remove_str = "_"+ } else {
|
||
| 74 | -+ | |||
| 192 | +1x |
- #' ) %>%+ lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
|
||
| 75 | -+ | |||
| 193 | +1x |
- #' build_table(df = df2)+ lvl_ord <- levels(grade)[order(as.numeric(lvls))] |
||
| 76 | +194 |
- #' result2+ } |
||
| 77 | -+ | |||
| 195 | +70x |
- #'+ grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl) |
||
| 78 | +196 |
- #' @export+ } |
||
| 79 | +197 |
- #' @order 1+ |
||
| 80 | -+ | |||
| 198 | +70x |
- summarize_logistic <- function(lyt,+ missing_lvl <- grepl("missing", tolower(levels(grade)))
|
||
| 81 | -+ | |||
| 199 | +70x |
- conf_level,+ if (any(missing_lvl)) {
|
||
| 82 | -+ | |||
| 200 | +1x |
- drop_and_remove_str = "",+ grade <- factor( |
||
| 83 | -+ | |||
| 201 | +1x |
- .indent_mods = NULL) {
+ grade, |
||
| 84 | -+ | |||
| 202 | +1x |
- # checks+ levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]), |
||
| 85 | -3x | +203 | +1x |
- checkmate::assert_string(drop_and_remove_str)+ ordered = is.ordered(grade) |
| 86 | +204 |
-
+ ) |
||
| 87 | -3x | -
- sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
+ | ||
| 205 | ++ |
+ } |
||
| 88 | -3x | +206 | +70x |
- sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
+ df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE) |
| 89 | -3x | +207 | +70x |
- sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
+ l_count <- as.list(table(df_max$grade)) |
| 90 | -3x | +|||
| 208 | +
- split_fun <- drop_and_remove_levels(drop_and_remove_str)+ } |
|||
| 91 | +209 | |||
| 92 | -3x | +210 | +75x |
- lyt <- logistic_regression_cols(lyt, conf_level = conf_level)+ if (length(grade_groups) > 0) {
|
| 93 | -3x | +211 | +30x |
- lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun)+ l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups) |
| 94 | -3x | +|||
| 212 | +
- lyt <- sum_logistic_variable_test(lyt)+ } |
|||
| 95 | -3x | +|||
| 213 | +
- lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun)+ |
|||
| 96 | -3x | +214 | +75x |
- lyt <- sum_logistic_term_estimates(lyt)+ l_count_fraction <- lapply( |
| 97 | -3x | +215 | +75x |
- lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun)+ l_count, |
| 98 | -3x | +216 | +75x |
- lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun)+ function(i, denom) {
|
| 99 | -3x | +217 | +299x |
- lyt <- sum_logistic_odds_ratios(lyt)+ if (i == 0 && denom == 0) {
|
| 100 | -3x | +218 | +9x |
- lyt+ c(0, 0) |
| 101 | +219 |
- }+ } else {
|
||
| 102 | -+ | |||
| 220 | +290x |
-
+ c(i, i / denom) |
||
| 103 | +221 |
- #' Fit for logistic regression+ } |
||
| 104 | +222 |
- #'+ }, |
||
| 105 | -+ | |||
| 223 | +75x |
- #' @description `r lifecycle::badge("stable")`
+ denom = denom |
||
| 106 | +224 |
- #'+ ) |
||
| 107 | +225 |
- #' Fit a (conditional) logistic regression model.+ |
||
| 108 | -+ | |||
| 226 | +75x |
- #'+ list( |
||
| 109 | -+ | |||
| 227 | +75x |
- #' @inheritParams argument_convention+ count_fraction = l_count_fraction |
||
| 110 | +228 |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ ) |
||
| 111 | +229 |
- #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ } |
||
| 112 | +230 |
- #' This will be used when fitting the (conditional) logistic regression model on the left hand+ |
||
| 113 | +231 |
- #' side of the formula.+ #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun` |
||
| 114 | +232 |
- #'+ #' in `count_occurrences_by_grade()`. |
||
| 115 | +233 |
- #' @return A fitted logistic regression model.+ #' |
||
| 116 | +234 |
- #'+ #' @return |
||
| 117 | +235 |
- #' @section Model Specification:+ #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 118 | +236 |
#' |
||
| 119 | +237 |
- #' The `variables` list needs to include the following elements:+ #' @examples |
||
| 120 | +238 |
- #' * `arm`: Treatment arm variable name.+ #' a_count_occurrences_by_grade( |
||
| 121 | +239 |
- #' * `response`: The response arm variable name. Usually this is a 0/1 variable.+ #' df, |
||
| 122 | +240 |
- #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names.+ #' .N_col = 10L, |
||
| 123 | +241 |
- #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already+ #' .N_row = 10L, |
||
| 124 | +242 |
- #' included in `covariates`. Then the interaction with the treatment arm is included in the model.+ #' .var = "AETOXGR", |
||
| 125 | +243 |
- #'+ #' id = "USUBJID", |
||
| 126 | +244 |
- #' @examples+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 127 | +245 |
- #' library(dplyr)+ #' ) |
||
| 128 | +246 |
#' |
||
| 129 | +247 |
- #' adrs_f <- tern_ex_adrs %>%+ #' @export |
||
| 130 | +248 |
- #' filter(PARAMCD == "BESRSPI") %>%+ a_count_occurrences_by_grade <- function(df, |
||
| 131 | +249 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ labelstr = "", |
||
| 132 | +250 |
- #' mutate(+ id = "USUBJID", |
||
| 133 | +251 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ grade_groups = list(), |
||
| 134 | +252 |
- #' RACE = factor(RACE),+ remove_single = TRUE, |
||
| 135 | +253 |
- #' SEX = factor(SEX)+ only_grade_groups = FALSE, |
||
| 136 | +254 |
- #' )+ denom = c("N_col", "n", "N_row"),
|
||
| 137 | +255 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ .N_col, # nolint |
||
| 138 | +256 |
- #' mod1 <- fit_logistic(+ .N_row, # nolint |
||
| 139 | +257 |
- #' data = adrs_f,+ .df_row, |
||
| 140 | +258 |
- #' variables = list(+ .var = NULL, |
||
| 141 | +259 |
- #' response = "Response",+ .stats = NULL, |
||
| 142 | +260 |
- #' arm = "ARMCD",+ .formats = NULL, |
||
| 143 | +261 |
- #' covariates = c("AGE", "RACE")
+ .labels = NULL, |
||
| 144 | +262 |
- #' )+ .indent_mods = NULL, |
||
| 145 | +263 |
- #' )+ na_str = default_na_str()) {
|
||
| 146 | -+ | |||
| 264 | +56x |
- #' mod2 <- fit_logistic(+ x_stats <- s_count_occurrences_by_grade( |
||
| 147 | -+ | |||
| 265 | +56x |
- #' data = adrs_f,+ df = df, .var = .var, .N_row = .N_row, .N_col = .N_col, id = id, |
||
| 148 | -+ | |||
| 266 | +56x |
- #' variables = list(+ grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, |
||
| 149 | -+ | |||
| 267 | +56x |
- #' response = "Response",+ denom = denom, labelstr = labelstr |
||
| 150 | +268 |
- #' arm = "ARMCD",+ ) |
||
| 151 | +269 |
- #' covariates = c("AGE", "RACE"),
+
|
||
| 152 | -+ | |||
| 270 | +56x |
- #' interaction = "AGE"+ if (is.null(unlist(x_stats))) {
|
||
| 153 | -+ | |||
| 271 | +! |
- #' )+ return(NULL) |
||
| 154 | +272 |
- #' )+ } |
||
| 155 | -+ | |||
| 273 | +56x |
- #'+ x_lvls <- names(x_stats[[1]]) |
||
| 156 | +274 |
- #' @export+ |
||
| 157 | +275 |
- fit_logistic <- function(data,+ # Fill in with formatting defaults if needed |
||
| 158 | -+ | |||
| 276 | +56x |
- variables = list(+ .stats <- get_stats("count_occurrences_by_grade", stats_in = .stats)
|
||
| 159 | -+ | |||
| 277 | +56x |
- response = "Response",+ if (length(.formats) == 1 && is.null(names(.formats))) {
|
||
| 160 | -+ | |||
| 278 | +4x |
- arm = "ARMCD",+ .formats <- rep(.formats, length(.stats)) %>% setNames(.stats) |
||
| 161 | +279 |
- covariates = NULL,+ } |
||
| 162 | -+ | |||
| 280 | +56x |
- interaction = NULL,+ .formats <- get_formats_from_stats(.stats, .formats) |
||
| 163 | -+ | |||
| 281 | +56x |
- strata = NULL+ .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls) |
||
| 164 | -+ | |||
| 282 | +56x |
- ),+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls) |
||
| 165 | +283 |
- response_definition = "response") {
- |
- ||
| 166 | -75x | -
- assert_df_with_variables(data, variables)- |
- ||
| 167 | -75x | -
- checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
+
|
||
| 168 | -75x | +284 | +1x |
- checkmate::assert_string(response_definition)+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
| 169 | -75x | +285 | +56x |
- checkmate::assert_true(grepl("response", response_definition))
+ x_stats <- x_stats[.stats] |
| 170 | +286 | |||
| 171 | -75x | -
- response_definition <- sub(- |
- ||
| 172 | -75x | +|||
| 287 | +
- pattern = "response",+ # Ungroup statistics with values for each level of x |
|||
| 173 | -75x | +288 | +56x |
- replacement = variables$response,+ x_ungrp <- ungroup_stats(x_stats, .formats, .labels, list()) |
| 174 | -75x | +289 | +56x |
- x = response_definition,+ x_stats <- x_ungrp[["x"]] |
| 175 | -75x | +290 | +56x |
- fixed = TRUE+ .formats <- x_ungrp[[".formats"]] |
| 176 | +291 |
- )- |
- ||
| 177 | -75x | -
- form <- paste0(response_definition, " ~ ", variables$arm)+ |
||
| 178 | -75x | +|||
| 292 | +
- if (!is.null(variables$covariates)) {
+ # Auto format handling |
|||
| 179 | -29x | +293 | +56x |
- form <- paste0(form, " + ", paste(variables$covariates, collapse = " + "))+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
| 180 | +294 |
- }+ |
||
| 181 | -75x | +295 | +56x |
- if (!is.null(variables$interaction)) {
+ in_rows( |
| 182 | -18x | +296 | +56x |
- checkmate::assert_string(variables$interaction)+ .list = x_stats, |
| 183 | -18x | +297 | +56x |
- checkmate::assert_subset(variables$interaction, variables$covariates)+ .formats = .formats, |
| 184 | -18x | +298 | +56x |
- form <- paste0(form, " + ", variables$arm, ":", variables$interaction)+ .names = unlist(.labels), |
| 185 | -+ | |||
| 299 | +56x |
- }+ .labels = unlist(.labels), |
||
| 186 | -75x | +300 | +56x |
- if (!is.null(variables$strata)) {
+ .indent_mods = .indent_mods, |
| 187 | -14x | +301 | +56x |
- strata_arg <- if (length(variables$strata) > 1) {
+ .format_na_strs = na_str |
| 188 | -7x | +|||
| 302 | +
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ ) |
|||
| 189 | +303 |
- } else {
+ } |
||
| 190 | -7x | +|||
| 304 | +
- variables$strata+ |
|||
| 191 | +305 |
- }+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function |
||
| 192 | -14x | +|||
| 306 | +
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 193 | +307 |
- }+ #' |
||
| 194 | -75x | +|||
| 308 | +
- formula <- stats::as.formula(form)+ #' @return |
|||
| 195 | -75x | +|||
| 309 | +
- if (is.null(variables$strata)) {
+ #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
|||
| 196 | -61x | +|||
| 310 | +
- stats::glm(+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 197 | -61x | +|||
| 311 | +
- formula = formula,+ #' the statistics from `s_count_occurrences_by_grade()` to the table layout. |
|||
| 198 | -61x | +|||
| 312 | +
- data = data,+ #' |
|||
| 199 | -61x | +|||
| 313 | +
- family = stats::binomial("logit")
+ #' @examples |
|||
| 200 | +314 |
- )+ #' library(dplyr) |
||
| 201 | +315 |
- } else {
+ #' |
||
| 202 | -14x | +|||
| 316 | +
- clogit_with_tryCatch(+ #' df <- data.frame( |
|||
| 203 | -14x | +|||
| 317 | +
- formula = formula,+ #' USUBJID = as.character(c(1:6, 1)), |
|||
| 204 | -14x | +|||
| 318 | +
- data = data,+ #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
|
|||
| 205 | -14x | +|||
| 319 | +
- x = TRUE+ #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)), |
|||
| 206 | +320 |
- )+ #' AESEV = factor( |
||
| 207 | +321 |
- }+ #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
|
||
| 208 | +322 |
- }+ #' levels = c("MILD", "MODERATE", "SEVERE")
|
||
| 209 | +323 |
-
+ #' ), |
||
| 210 | +324 |
- #' Custom tidy method for binomial GLM results+ #' stringsAsFactors = FALSE |
||
| 211 | +325 |
- #'+ #' ) |
||
| 212 | +326 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 213 | +327 |
- #'+ #' df_adsl <- df %>% |
||
| 214 | +328 |
- #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object+ #' select(USUBJID, ARM) %>% |
||
| 215 | +329 |
- #' with `binomial` family.+ #' unique() |
||
| 216 | +330 |
#' |
||
| 217 | +331 |
- #' @inheritParams argument_convention+ #' # Layout creating function with custom format. |
||
| 218 | +332 |
- #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise the median is used.+ #' basic_table() %>% |
||
| 219 | +333 |
- #' @param x (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.+ #' split_cols_by("ARM") %>%
|
||
| 220 | +334 |
- #'+ #' add_colcounts() %>% |
||
| 221 | +335 |
- #' @return A `data.frame` containing the tidied model.+ #' count_occurrences_by_grade( |
||
| 222 | +336 |
- #'+ #' var = "AESEV", |
||
| 223 | +337 |
- #' @method tidy glm+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 224 | +338 |
- #'+ #' ) %>% |
||
| 225 | +339 |
- #' @seealso [h_logistic_regression] for relevant helper functions.+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 226 | +340 |
#' |
||
| 227 | +341 |
- #' @examples+ #' # Define additional grade groupings. |
||
| 228 | +342 |
- #' library(dplyr)+ #' grade_groups <- list( |
||
| 229 | +343 |
- #' library(broom)+ #' "-Any-" = c("1", "2", "3", "4", "5"),
|
||
| 230 | +344 |
- #'+ #' "Grade 1-2" = c("1", "2"),
|
||
| 231 | +345 |
- #' adrs_f <- tern_ex_adrs %>%+ #' "Grade 3-5" = c("3", "4", "5")
|
||
| 232 | +346 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' ) |
||
| 233 | +347 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' |
||
| 234 | +348 |
- #' mutate(+ #' basic_table() %>% |
||
| 235 | +349 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' split_cols_by("ARM") %>%
|
||
| 236 | +350 |
- #' RACE = factor(RACE),+ #' add_colcounts() %>% |
||
| 237 | +351 |
- #' SEX = factor(SEX)+ #' count_occurrences_by_grade( |
||
| 238 | +352 |
- #' )+ #' var = "AETOXGR", |
||
| 239 | +353 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ #' grade_groups = grade_groups, |
||
| 240 | +354 |
- #' mod1 <- fit_logistic(+ #' only_grade_groups = TRUE |
||
| 241 | +355 |
- #' data = adrs_f,+ #' ) %>% |
||
| 242 | +356 |
- #' variables = list(+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 243 | +357 |
- #' response = "Response",+ #' |
||
| 244 | +358 |
- #' arm = "ARMCD",+ #' @export |
||
| 245 | +359 |
- #' covariates = c("AGE", "RACE")
+ #' @order 2 |
||
| 246 | +360 |
- #' )+ count_occurrences_by_grade <- function(lyt, |
||
| 247 | +361 |
- #' )+ var, |
||
| 248 | +362 |
- #' mod2 <- fit_logistic(+ id = "USUBJID", |
||
| 249 | +363 |
- #' data = adrs_f,+ grade_groups = list(), |
||
| 250 | +364 |
- #' variables = list(+ remove_single = TRUE, |
||
| 251 | +365 |
- #' response = "Response",+ only_grade_groups = FALSE, |
||
| 252 | +366 |
- #' arm = "ARMCD",+ var_labels = var, |
||
| 253 | +367 |
- #' covariates = c("AGE", "RACE"),
+ show_labels = "default", |
||
| 254 | +368 |
- #' interaction = "AGE"+ riskdiff = FALSE, |
||
| 255 | +369 |
- #' )+ na_str = default_na_str(), |
||
| 256 | +370 |
- #' )+ nested = TRUE, |
||
| 257 | +371 |
- #'+ ..., |
||
| 258 | +372 |
- #' df <- tidy(mod1, conf_level = 0.99)+ table_names = var, |
||
| 259 | +373 |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ .stats = "count_fraction", |
||
| 260 | +374 |
- #'+ .formats = list(count_fraction = format_count_fraction_fixed_dp), |
||
| 261 | +375 |
- #' @export+ .indent_mods = NULL, |
||
| 262 | +376 |
- tidy.glm <- function(x, # nolint+ .labels = NULL) {
|
||
| 263 | -+ | |||
| 377 | +12x |
- conf_level = 0.95,+ checkmate::assert_flag(riskdiff) |
||
| 264 | -+ | |||
| 378 | +12x |
- at = NULL,+ extra_args <- list(+ |
+ ||
| 379 | +12x | +
+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
||
| 265 | +380 |
- ...) {
+ ) |
||
| 266 | -5x | +381 | +12x |
- checkmate::assert_class(x, "glm")+ s_args <- list( |
| 267 | -5x | +382 | +12x |
- checkmate::assert_set_equal(x$family$family, "binomial")+ id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ... |
| 268 | +383 | ++ |
+ )+ |
+ |
| 384 | ||||
| 269 | -5x | +385 | +12x |
- terms_name <- attr(stats::terms(x), "term.labels")+ if (isFALSE(riskdiff)) {
|
| 270 | -5x | +386 | +10x |
- xs_class <- attr(x$terms, "dataClasses")+ extra_args <- c(extra_args, s_args) |
| 271 | -5x | +|||
| 387 | +
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ } else {
|
|||
| 272 | -5x | +388 | +2x |
- df <- if (length(interaction) == 0) {
+ extra_args <- c( |
| 273 | +389 | 2x |
- h_logistic_simple_terms(+ extra_args, |
|
| 274 | +390 | 2x |
- x = terms_name,+ list( |
|
| 275 | +391 | 2x |
- fit_glm = x,+ afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
|
|
| 276 | +392 | 2x |
- conf_level = conf_level+ s_args = s_args |
|
| 277 | +393 |
- )+ ) |
||
| 278 | +394 |
- } else {
+ ) |
||
| 279 | -3x | +|||
| 395 | +
- h_logistic_inter_terms(+ } |
|||
| 280 | -3x | +|||
| 396 | +
- x = terms_name,+ |
|||
| 281 | -3x | +397 | +12x |
- fit_glm = x,+ analyze( |
| 282 | -3x | +398 | +12x |
- conf_level = conf_level,+ lyt = lyt, |
| 283 | -3x | +399 | +12x |
- at = at+ vars = var, |
| 284 | -+ | |||
| 400 | +12x |
- )+ afun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff), |
||
| 285 | -+ | |||
| 401 | +12x |
- }+ var_labels = var_labels, |
||
| 286 | -5x | +402 | +12x |
- for (var in c("variable", "term", "interaction", "reference")) {
+ show_labels = show_labels, |
| 287 | -20x | +403 | +12x |
- df[[var]] <- factor(df[[var]], levels = unique(df[[var]]))+ table_names = table_names, |
| 288 | -+ | |||
| 404 | +12x |
- }+ na_str = na_str, |
||
| 289 | -5x | +405 | +12x |
- df+ nested = nested,+ |
+
| 406 | +12x | +
+ extra_args = extra_args |
||
| 290 | +407 |
- }+ ) |
||
| 291 | +408 |
-
+ } |
||
| 292 | +409 |
- #' Logistic regression multivariate column layout function+ |
||
| 293 | +410 |
- #'+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments |
||
| 294 | +411 |
- #' @description `r lifecycle::badge("stable")`
+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 295 | +412 |
#' |
||
| 296 | +413 |
- #' Layout-creating function which creates a multivariate column layout summarizing logistic+ #' @return |
||
| 297 | +414 |
- #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()].+ #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 298 | +415 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 299 | +416 |
- #' @inheritParams argument_convention+ #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout. |
||
| 300 | +417 |
#' |
||
| 301 | +418 |
- #' @return A layout object suitable for passing to further layouting functions. Adding this+ #' @examples |
||
| 302 | +419 |
- #' function to an `rtable` layout will split the table into columns corresponding to+ #' # Layout creating function with custom format. |
||
| 303 | +420 |
- #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`.+ #' basic_table() %>% |
||
| 304 | +421 |
- #'+ #' add_colcounts() %>% |
||
| 305 | +422 |
- #' @export+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
||
| 306 | +423 |
- logistic_regression_cols <- function(lyt,+ #' summarize_occurrences_by_grade( |
||
| 307 | +424 |
- conf_level = 0.95) {
+ #' var = "AESEV", |
||
| 308 | -4x | +|||
| 425 | +
- vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
|||
| 309 | -4x | +|||
| 426 | +
- var_labels <- c(+ #' ) %>% |
|||
| 310 | -4x | +|||
| 427 | +
- df = "Degrees of Freedom",+ #' build_table(df, alt_counts_df = df_adsl) |
|||
| 311 | -4x | +|||
| 428 | +
- estimate = "Parameter Estimate",+ #' |
|||
| 312 | -4x | +|||
| 429 | +
- std_error = "Standard Error",+ #' basic_table() %>% |
|||
| 313 | -4x | +|||
| 430 | +
- odds_ratio = "Odds Ratio",+ #' add_colcounts() %>% |
|||
| 314 | -4x | +|||
| 431 | +
- ci = paste("Wald", f_conf_level(conf_level)),
+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
|||
| 315 | -4x | +|||
| 432 | +
- pvalue = "p-value"+ #' summarize_occurrences_by_grade( |
|||
| 316 | +433 |
- )+ #' var = "AETOXGR", |
||
| 317 | -4x | +|||
| 434 | +
- split_cols_by_multivar(+ #' grade_groups = grade_groups |
|||
| 318 | -4x | +|||
| 435 | +
- lyt = lyt,+ #' ) %>% |
|||
| 319 | -4x | +|||
| 436 | +
- vars = vars,+ #' build_table(df, alt_counts_df = df_adsl) |
|||
| 320 | -4x | +|||
| 437 | +
- varlabels = var_labels+ #' |
|||
| 321 | +438 |
- )+ #' @export |
||
| 322 | +439 |
- }+ #' @order 3 |
||
| 323 | +440 |
-
+ summarize_occurrences_by_grade <- function(lyt, |
||
| 324 | +441 |
- #' Logistic regression summary table+ var, |
||
| 325 | +442 |
- #'+ id = "USUBJID", |
||
| 326 | +443 |
- #' @description `r lifecycle::badge("stable")`
+ grade_groups = list(), |
||
| 327 | +444 |
- #'+ remove_single = TRUE, |
||
| 328 | +445 |
- #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize+ only_grade_groups = FALSE, |
||
| 329 | +446 |
- #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()].+ riskdiff = FALSE, |
||
| 330 | +447 |
- #'+ na_str = default_na_str(), |
||
| 331 | +448 |
- #' @inheritParams argument_convention+ ..., |
||
| 332 | +449 |
- #' @param flag_var (`string`)\cr variable name identifying which row should be used in this+ .stats = "count_fraction", |
||
| 333 | +450 |
- #' content function.+ .formats = list(count_fraction = format_count_fraction_fixed_dp), |
||
| 334 | +451 |
- #'+ .indent_mods = NULL, |
||
| 335 | +452 |
- #' @return A content function.+ .labels = NULL) {
+ |
+ ||
| 453 | +6x | +
+ checkmate::assert_flag(riskdiff)+ |
+ ||
| 454 | +6x | +
+ extra_args <- list(+ |
+ ||
| 455 | +6x | +
+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
||
| 336 | +456 |
- #'+ )+ |
+ ||
| 457 | +6x | +
+ s_args <- list(+ |
+ ||
| 458 | +6x | +
+ id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ... |
||
| 337 | +459 |
- #' @export+ ) |
||
| 338 | +460 |
- logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
+
|
||
| 339 | -10x | +461 | +6x |
- checkmate::assert_string(flag_var)+ if (isFALSE(riskdiff)) {
|
| 340 | -10x | +462 | +4x |
- function(lyt) {
+ extra_args <- c(extra_args, s_args) |
| 341 | -10x | +|||
| 463 | +
- cfun_list <- list(+ } else {
|
|||
| 342 | -10x | +464 | +2x |
- df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
+ extra_args <- c( |
| 343 | -10x | +465 | +2x |
- estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ extra_args, |
| 344 | -10x | +466 | +2x |
- std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ list( |
| 345 | -10x | +467 | +2x |
- odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
+ afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
|
| 346 | -10x | +468 | +2x |
- ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
+ s_args = s_args |
| 347 | -10x | +|||
| 469 | +
- pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
+ ) |
|||
| 348 | +470 |
) |
||
| 471 | ++ |
+ }+ |
+ ||
| 472 | ++ | + + | +||
| 349 | -10x | +473 | +6x |
- summarize_row_groups(+ summarize_row_groups( |
| 350 | -10x | +474 | +6x |
- lyt = lyt,+ lyt = lyt, |
| 351 | -10x | +475 | +6x |
- cfun = cfun_list,+ var = var, |
| 352 | -10x | +476 | +6x |
- na_str = na_str+ cfun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff), |
| 353 | -+ | |||
| 477 | +6x |
- )+ na_str = na_str,+ |
+ ||
| 478 | +6x | +
+ extra_args = extra_args |
||
| 354 | +479 |
- }+ ) |
||
| 355 | +480 |
}@@ -165415,14 +164407,14 @@ tern coverage - 95.65% |
| 1 |
- #' Summarize variables in columns+ #' Survival time analysis |
||
| 5 |
- #' The analyze function [summarize_colvars()] uses the statistics function [s_summary()] to analyze variables that are+ #' The analyze function [surv_time()] creates a layout element to analyze survival time by calculating survival time |
||
| 6 |
- #' arranged in columns. The variables to analyze should be specified in the table layout via column splits (see+ #' median, median confidence interval, quantiles, and range (for all, censored, or event patients). The primary |
||
| 7 |
- #' [rtables::split_cols_by()] and [rtables::split_cols_by_multivar()]) prior to using [summarize_colvars()].+ #' analysis variable `vars` is the time variable and the secondary analysis variable `is_event` indicates whether or |
||
| 8 |
- #'+ #' not an event has occurred. |
||
| 9 |
- #' The function is a minimal wrapper for [rtables::analyze_colvars()], a function typically used to apply different+ #' |
||
| 10 |
- #' analysis methods in rows for each column variable. To use the analysis methods as column labels, please refer to+ #' @inheritParams argument_convention |
||
| 11 |
- #' the [analyze_vars_in_cols()] function.+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 12 |
- #'+ #' [control_surv_time()]. Some possible parameter options are: |
||
| 13 |
- #' @inheritParams argument_convention+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time. |
||
| 14 |
- #' @param ... arguments passed to [s_summary()].+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log", |
||
| 15 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' see more in [survival::survfit()]. Note option "none" is not supported. |
||
| 16 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time. |
||
| 17 |
- #' for that statistic's row label.+ #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed |
||
| 18 |
- #'+ #' when the `range` statistic is included. |
||
| 19 |
- #' @return+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 20 |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 21 |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ #' for that statistic's row label. |
||
| 22 |
- #' in columns, and add it to the table layout.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 24 |
- #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`].+ #' Options are: ``r shQuote(get_stats("surv_time"))``
|
||
| 27 |
- #' dta_test <- data.frame(+ #' library(dplyr) |
||
| 28 |
- #' USUBJID = rep(1:6, each = 3),+ #' |
||
| 29 |
- #' PARAMCD = rep("lab", 6 * 3),
+ #' adtte_f <- tern_ex_adtte %>% |
||
| 30 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' filter(PARAMCD == "OS") %>% |
||
| 31 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' mutate( |
||
| 32 |
- #' AVAL = c(9:1, rep(NA, 9)),+ #' AVAL = day2month(AVAL), |
||
| 33 |
- #' CHG = c(1:9, rep(NA, 9))+ #' is_event = CNSR == 0 |
||
| 34 |
- #' )+ #' ) |
||
| 35 |
- #'+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 36 |
- #' ## Default output within a `rtables` pipeline.+ #' |
||
| 37 |
- #' basic_table() %>%+ #' @name survival_time |
||
| 38 |
- #' split_cols_by("ARM") %>%
+ #' @order 1 |
||
| 39 |
- #' split_rows_by("AVISIT") %>%
+ NULL |
||
| 40 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+
|
||
| 41 |
- #' summarize_colvars() %>%+ #' @describeIn survival_time Statistics function which analyzes survival times. |
||
| 42 |
- #' build_table(dta_test)+ #' |
||
| 43 |
- #'+ #' @return |
||
| 44 |
- #' ## Selection of statistics, formats and labels also work.+ #' * `s_surv_time()` returns the statistics: |
||
| 45 |
- #' basic_table() %>%+ #' * `median`: Median survival time. |
||
| 46 |
- #' split_cols_by("ARM") %>%
+ #' * `median_ci`: Confidence interval for median time. |
||
| 47 |
- #' split_rows_by("AVISIT") %>%
+ #' * `quantiles`: Survival time for two specified quantiles. |
||
| 48 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ #' * `range_censor`: Survival time range for censored observations. |
||
| 49 |
- #' summarize_colvars(+ #' * `range_event`: Survival time range for observations with events. |
||
| 50 |
- #' .stats = c("n", "mean_sd"),
+ #' * `range`: Survival time range for all observations. |
||
| 51 |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ #' |
||
| 52 |
- #' .labels = c(n = "n", mean_sd = "Mean, SD")+ #' @keywords internal |
||
| 53 |
- #' ) %>%+ s_surv_time <- function(df, |
||
| 54 |
- #' build_table(dta_test)+ .var, |
||
| 55 |
- #'+ is_event, |
||
| 56 |
- #' ## Use arguments interpreted by `s_summary`.+ control = control_surv_time()) {
|
||
| 57 | -+ | 232x |
- #' basic_table() %>%+ checkmate::assert_string(.var) |
| 58 | -+ | 232x |
- #' split_cols_by("ARM") %>%
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 59 | -+ | 232x |
- #' split_rows_by("AVISIT") %>%
+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
| 60 | -+ | 232x |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
| 61 |
- #' summarize_colvars(na.rm = FALSE) %>%+ |
||
| 62 | -+ | 232x |
- #' build_table(dta_test)+ conf_type <- control$conf_type |
| 63 | -+ | 232x |
- #'+ conf_level <- control$conf_level |
| 64 | -+ | 232x |
- #' @export+ quantiles <- control$quantiles |
| 65 |
- summarize_colvars <- function(lyt,+ |
||
| 66 | -+ | 232x |
- ...,+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
| 67 | -+ | 232x |
- na_str = default_na_str(),+ srv_fit <- survival::survfit( |
| 68 | -+ | 232x |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ formula = formula, |
| 69 | -+ | 232x |
- .formats = NULL,+ data = df, |
| 70 | -+ | 232x |
- .labels = NULL,+ conf.int = conf_level, |
| 71 | -+ | 232x |
- .indent_mods = NULL) {
+ conf.type = conf_type |
| 72 | -3x | +
- extra_args <- list(.stats = .stats, na_str = na_str, ...)+ ) |
|
| 73 | -1x | +232x |
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ srv_tab <- summary(srv_fit, extend = TRUE)$table |
| 74 | -1x | +232x |
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile |
| 75 | -1x | +232x |
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE) |
| 76 | -+ | 232x |
-
+ range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE) |
| 77 | -3x | +232x |
- analyze_colvars(+ range <- range_noinf(df[[.var]], na.rm = TRUE) |
| 78 | -3x | +232x |
- lyt,+ list( |
| 79 | -3x | +232x |
- afun = a_summary,+ median = formatters::with_label(unname(srv_tab["median"]), "Median"), |
| 80 | -3x | +232x |
- na_str = na_str,+ median_ci = formatters::with_label( |
| 81 | -3x | +232x |
- extra_args = extra_args+ unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
|
| 82 |
- )+ ), |
||
| 83 | -+ | 232x |
- }+ quantiles = formatters::with_label( |
| 1 | -+ | ||
| 84 | +232x |
- #' Kaplan-Meier plot+ unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile") |
|
| 2 | +85 |
- #'+ ), |
|
| 3 | -+ | ||
| 86 | +232x |
- #' @description `r lifecycle::badge("stable")`
+ range_censor = formatters::with_label(range_censor, "Range (censored)"), |
|
| 4 | -+ | ||
| 87 | +232x |
- #'+ range_event = formatters::with_label(range_event, "Range (event)"), |
|
| 5 | -+ | ||
| 88 | +232x |
- #' From a survival model, a graphic is rendered along with tabulated annotation+ range = formatters::with_label(range, "Range") |
|
| 6 | +89 |
- #' including the number of patient at risk at given time and the median survival+ ) |
|
| 7 | +90 |
- #' per group.+ } |
|
| 8 | +91 |
- #'+ |
|
| 9 | +92 |
- #' @inheritParams argument_convention+ #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`. |
|
| 10 | +93 |
- #' @param variables (named `list`)\cr variable names. Details are:+ #' |
|
| 11 | +94 |
- #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values.+ #' @return |
|
| 12 | +95 |
- #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.+ #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 13 | +96 |
- #' * `arm` (`factor`)\cr the treatment group variable.+ #' |
|
| 14 | +97 |
- #' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors.+ #' @examples |
|
| 15 | +98 |
- #' @param control_surv (`list`)\cr parameters for comparison details, specified by using+ #' a_surv_time( |
|
| 16 | +99 |
- #' the helper function [control_surv_timepoint()]. Some possible parameter options are:+ #' df, |
|
| 17 | +100 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ #' .df_row = df, |
|
| 18 | +101 |
- #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type,+ #' .var = "AVAL", |
|
| 19 | +102 |
- #' see more in [survival::survfit()]. Note that the option "none" is no longer supported.+ #' is_event = "is_event" |
|
| 20 | +103 |
- #' @param col (`character`)\cr lines colors. Length of a vector should be equal+ #' ) |
|
| 21 | +104 |
- #' to number of strata from [survival::survfit()].+ #' |
|
| 22 | +105 |
- #' @param lty (`numeric`)\cr line type. If a vector is given, its length should be equal to the number of strata from+ #' @export |
|
| 23 | +106 |
- #' [survival::survfit()].+ a_surv_time <- function(df, |
|
| 24 | +107 |
- #' @param lwd (`numeric`)\cr line width. If a vector is given, its length should be equal to the number of strata from+ labelstr = "", |
|
| 25 | +108 |
- #' [survival::survfit()].+ .var = NULL, |
|
| 26 | +109 |
- #' @param censor_show (`flag`)\cr whether to show censored observations.+ .df_row = NULL, |
|
| 27 | +110 |
- #' @param pch (`string`)\cr name of symbol or character to use as point symbol to indicate censored cases.+ is_event, |
|
| 28 | +111 |
- #' @param size (`numeric(1)`)\cr size of censored point symbols.+ control = control_surv_time(), |
|
| 29 | +112 |
- #' @param max_time (`numeric(1)`)\cr maximum value to show on x-axis. Only data values less than or up to+ ref_fn_censor = TRUE, |
|
| 30 | +113 |
- #' this threshold value will be plotted (defaults to `NULL`).+ .stats = NULL, |
|
| 31 | +114 |
- #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing+ .formats = NULL, |
|
| 32 | +115 |
- #' between ticks on the x-axis. If `NULL` (default), [labeling::extended()] is used to determine+ .labels = NULL, |
|
| 33 | +116 |
- #' optimal tick positions on the x-axis.+ .indent_mods = NULL, |
|
| 34 | +117 |
- #' @param xlab (`string`)\cr x-axis label.+ na_str = default_na_str()) {
|
|
| 35 | -+ | ||
| 118 | +14x |
- #' @param yval (`string`)\cr type of plot, to be plotted on the y-axis. Options are `Survival` (default) and `Failure`+ x_stats <- s_surv_time( |
|
| 36 | -+ | ||
| 119 | +14x |
- #' probability.+ df = df, .var = .var, is_event = is_event, control = control |
|
| 37 | +120 |
- #' @param ylab (`string`)\cr y-axis label.+ ) |
|
| 38 | -+ | ||
| 121 | +14x |
- #' @param title (`string`)\cr plot title.+ rng_censor_lwr <- x_stats[["range_censor"]][1] |
|
| 39 | -+ | ||
| 122 | +14x |
- #' @param footnotes (`string`)\cr plot footnotes.+ rng_censor_upr <- x_stats[["range_censor"]][2] |
|
| 40 | +123 |
- #' @param font_size (`numeric(1)`)\cr font size to use for all text.+ |
|
| 41 | +124 |
- #' @param ci_ribbon (`flag`)\cr whether the confidence interval should be drawn around the Kaplan-Meier curve.+ # Use method-specific defaults |
|
| 42 | -+ | ||
| 125 | +14x |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk+ fmts <- c(median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x") |
|
| 43 | -+ | ||
| 126 | +14x |
- #' matching the main grid of the Kaplan-Meier curve.+ lbls <- c(median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)") |
|
| 44 | -+ | ||
| 127 | +14x |
- #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ lbls_custom <- .labels |
|
| 45 | -+ | ||
| 128 | +14x |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))]) |
|
| 46 | -+ | ||
| 129 | +14x |
- #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the+ .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))]) |
|
| 47 | +130 |
- #' median survival time per group.+ |
|
| 48 | +131 |
- #' @param annot_coxph (`flag`)\cr whether to add the annotation table from a [survival::coxph()] model.+ # Fill in with formatting defaults if needed |
|
| 49 | -+ | ||
| 132 | +14x |
- #' @param annot_stats (`string` or `NULL`)\cr statistics annotations to add to the plot. Options are+ .stats <- get_stats("surv_time", stats_in = .stats)
|
|
| 50 | -+ | ||
| 133 | +14x |
- #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time).+ .formats <- get_formats_from_stats(.stats, .formats) |
|
| 51 | -+ | ||
| 134 | +14x |
- #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics+ .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom) |
|
| 52 | -+ | ||
| 135 | +14x |
- #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
|
| 53 | +136 |
- #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified using the helper function+ |
|
| 54 | -+ | ||
| 137 | +14x |
- #' [control_coxph()]. Some possible parameter options are:+ x_stats <- x_stats[.stats] |
|
| 55 | +138 |
- #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.+ |
|
| 56 | +139 |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ # Auto format handling |
|
| 57 | -+ | ||
| 140 | +14x |
- #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`,+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
|
| 58 | +141 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ |
|
| 59 | -+ | ||
| 142 | +14x |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
|
|
| 60 | -+ | ||
| 143 | +14x |
- #' @param ref_group_coxph (`string` or `NULL`)\cr level of arm variable to use as reference group in calculations for+ if ("range" %in% names(x_stats) && ref_fn_censor) {
|
|
| 61 | -+ | ||
| 144 | +14x |
- #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable.+ if (identical(x_stats[["range"]][1], rng_censor_lwr) && identical(x_stats[["range"]][2], rng_censor_upr)) {
|
|
| 62 | -+ | ||
| 145 | +2x |
- #' @param control_annot_surv_med (`list`)\cr parameters to control the position and size of the annotation table added+ cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum" |
|
| 63 | -+ | ||
| 146 | +12x |
- #' to the plot when `annot_surv_med = TRUE`, specified using the [control_surv_med_annot()] function. Parameter+ } else if (identical(x_stats[["range"]][1], rng_censor_lwr)) {
|
|
| 64 | -+ | ||
| 147 | +2x |
- #' options are: `x`, `y`, `w`, `h`, and `fill`. See [control_surv_med_annot()] for details.+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum" |
|
| 65 | -+ | ||
| 148 | +10x |
- #' @param control_annot_coxph (`list`)\cr parameters to control the position and size of the annotation table added+ } else if (identical(x_stats[["range"]][2], rng_censor_upr)) {
|
|
| 66 | -+ | ||
| 149 | +1x |
- #' to the plot when `annot_coxph = TRUE`, specified using the [control_coxph_annot()] function. Parameter+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum" |
|
| 67 | +150 |
- #' options are: `x`, `y`, `w`, `h`, `fill`, and `ref_lbls`. See [control_coxph_annot()] for details.+ } |
|
| 68 | +151 |
- #' @param legend_pos (`numeric(2)` or `NULL`)\cr vector containing x- and y-coordinates, respectively, for the legend+ } |
|
| 69 | +152 |
- #' position relative to the KM plot area. If `NULL` (default), the legend is positioned in the bottom right corner of+ |
|
| 70 | -+ | ||
| 153 | +14x |
- #' the plot, or the middle right of the plot if needed to prevent overlapping.+ in_rows( |
|
| 71 | -+ | ||
| 154 | +14x |
- #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the Kaplan-Meier plot.+ .list = x_stats, |
|
| 72 | -+ | ||
| 155 | +14x |
- #' Relative height of patients at risk table is then `1 - rel_height_plot`. If `annot_at_risk = FALSE` or+ .formats = .formats, |
|
| 73 | -+ | ||
| 156 | +14x |
- #' `as_list = TRUE`, this parameter is ignored.+ .names = .labels, |
|
| 74 | -+ | ||
| 157 | +14x |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to format the Kaplan-Meier plot.+ .labels = .labels, |
|
| 75 | -+ | ||
| 158 | +14x |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `annot_at_risk = TRUE`.+ .indent_mods = .indent_mods, |
|
| 76 | -+ | ||
| 159 | +14x |
- #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the patients+ .format_na_strs = na_str, |
|
| 77 | -+ | ||
| 160 | +14x |
- #' at risk table is printed below the plot via [cowplot::plot_grid()].+ .cell_footnotes = cell_fns |
|
| 78 | +161 |
- #' @param draw `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ ) |
|
| 79 | +162 |
- #' @param newpage `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ } |
|
| 80 | +163 |
- #' @param gp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+
|
|
| 81 | +164 |
- #' @param vp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ #' @describeIn survival_time Layout-creating function which can take statistics function arguments |
|
| 82 | +165 |
- #' @param name `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 83 | +166 |
- #' @param annot_coxph_ref_lbls `r lifecycle::badge("deprecated")` Please use the `ref_lbls` element of
+ #' |
|
| 84 | +167 |
- #' `control_annot_coxph` instead.+ #' @return |
|
| 85 | +168 |
- #' @param position_coxph `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ #' * `surv_time()` returns a layout object suitable for passing to further layouting functions, |
|
| 86 | +169 |
- #' `control_annot_coxph` instead.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 87 | +170 |
- #' @param position_surv_med `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ #' the statistics from `s_surv_time()` to the table layout. |
|
| 88 | +171 |
- #' `control_annot_surv_med` instead.+ #' |
|
| 89 | +172 |
- #' @param width_annots `r lifecycle::badge("deprecated")` Please use the `w` element of `control_annot_surv_med`
+ #' @examples |
|
| 90 | +173 |
- #' (for `surv_med`) and `control_annot_coxph` (for `coxph`)."+ #' basic_table() %>% |
|
| 91 | +174 |
- #'+ #' split_cols_by(var = "ARMCD") %>% |
|
| 92 | +175 |
- #' @return A `ggplot` Kaplan-Meier plot and (optionally) summary table.+ #' add_colcounts() %>% |
|
| 93 | +176 |
- #'+ #' surv_time( |
|
| 94 | +177 |
- #' @examples+ #' vars = "AVAL", |
|
| 95 | +178 |
- #' library(dplyr)+ #' var_labels = "Survival Time (Months)", |
|
| 96 | +179 |
- #'+ #' is_event = "is_event", |
|
| 97 | +180 |
- #' df <- tern_ex_adtte %>%+ #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log") |
|
| 98 | +181 |
- #' filter(PARAMCD == "OS") %>%+ #' ) %>% |
|
| 99 | +182 |
- #' mutate(is_event = CNSR == 0)+ #' build_table(df = adtte_f) |
|
| 100 | +183 |
- #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")+ #' |
|
| 101 | +184 |
- #'+ #' @export |
|
| 102 | +185 |
- #' # Basic examples+ #' @order 2 |
|
| 103 | +186 |
- #' g_km(df = df, variables = variables)+ surv_time <- function(lyt, |
|
| 104 | +187 |
- #' g_km(df = df, variables = variables, yval = "Failure")+ vars, |
|
| 105 | +188 |
- #'+ is_event, |
|
| 106 | +189 |
- #' # Examples with customization parameters applied+ control = control_surv_time(), |
|
| 107 | +190 |
- #' g_km(+ ref_fn_censor = TRUE, |
|
| 108 | +191 |
- #' df = df,+ na_str = default_na_str(), |
|
| 109 | +192 |
- #' variables = variables,+ nested = TRUE, |
|
| 110 | +193 |
- #' control_surv = control_surv_timepoint(conf_level = 0.9),+ ..., |
|
| 111 | +194 |
- #' col = c("grey25", "grey50", "grey75"),
+ var_labels = "Time to Event", |
|
| 112 | +195 |
- #' annot_at_risk_title = FALSE,+ show_labels = "visible", |
|
| 113 | +196 |
- #' lty = 1:3,+ table_names = vars, |
|
| 114 | +197 |
- #' font_size = 8+ .stats = c("median", "median_ci", "quantiles", "range"),
|
|
| 115 | +198 |
- #' )+ .formats = NULL, |
|
| 116 | +199 |
- #' g_km(+ .labels = NULL, |
|
| 117 | +200 |
- #' df = df,+ .indent_mods = c(median_ci = 1L)) {
|
|
| 118 | -+ | ||
| 201 | +3x |
- #' variables = variables,+ extra_args <- list( |
|
| 119 | -+ | ||
| 202 | +3x |
- #' annot_stats = c("min", "median"),
+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str, |
|
| 120 | -+ | ||
| 203 | +3x |
- #' annot_stats_vlines = TRUE,+ is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ... |
|
| 121 | +204 |
- #' max_time = 3000,+ ) |
|
| 122 | +205 |
- #' ggtheme = ggplot2::theme_minimal()+ |
|
| 123 | -+ | ||
| 206 | +3x |
- #' )+ analyze( |
|
| 124 | -+ | ||
| 207 | +3x |
- #'+ lyt = lyt, |
|
| 125 | -+ | ||
| 208 | +3x |
- #' # Example with pairwise Cox-PH analysis annotation table, adjusted annotation tables+ vars = vars, |
|
| 126 | -+ | ||
| 209 | +3x |
- #' g_km(+ afun = a_surv_time, |
|
| 127 | -+ | ||
| 210 | +3x |
- #' df = df, variables = variables,+ var_labels = var_labels, |
|
| 128 | -+ | ||
| 211 | +3x |
- #' annot_coxph = TRUE,+ show_labels = show_labels, |
|
| 129 | -+ | ||
| 212 | +3x |
- #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ table_names = table_names, |
|
| 130 | -+ | ||
| 213 | +3x |
- #' control_annot_coxph = control_coxph_annot(x = 0.26, w = 0.35),+ na_str = na_str, |
|
| 131 | -+ | ||
| 214 | +3x |
- #' control_annot_surv_med = control_surv_med_annot(x = 0.8, y = 0.9, w = 0.35)+ nested = nested, |
|
| 132 | -+ | ||
| 215 | +3x |
- #' )+ extra_args = extra_args |
|
| 133 | +216 |
- #'+ ) |
|
| 134 | +217 |
- #' @aliases kaplan_meier+ } |
| 135 | +1 |
- #' @export+ #' Additional assertions to use with `checkmate` |
||
| 136 | +2 |
- g_km <- function(df,+ #' |
||
| 137 | +3 |
- variables,+ #' Additional assertion functions which can be used together with the `checkmate` package. |
||
| 138 | +4 |
- control_surv = control_surv_timepoint(),+ #' |
||
| 139 | +5 |
- col = NULL,+ #' @inheritParams checkmate::assert_factor |
||
| 140 | +6 |
- lty = NULL,+ #' @param x (`any`)\cr object to test. |
||
| 141 | +7 |
- lwd = 0.5,+ #' @param df (`data.frame`)\cr data set to test. |
||
| 142 | +8 |
- censor_show = TRUE,+ #' @param variables (named `list` of `character`)\cr list of variables to test. |
||
| 143 | +9 |
- pch = 3,+ #' @param include_boundaries (`flag`)\cr whether to include boundaries when testing |
||
| 144 | +10 |
- size = 2,+ #' for proportions. |
||
| 145 | +11 |
- max_time = NULL,+ #' @param na_level (`string`)\cr the string you have been using to represent NA or |
||
| 146 | +12 |
- xticks = NULL,+ #' missing data. For `NA` values please consider using directly [is.na()] or |
||
| 147 | +13 |
- xlab = "Days",+ #' similar approaches. |
||
| 148 | +14 |
- yval = c("Survival", "Failure"),
+ #' |
||
| 149 | +15 |
- ylab = paste(yval, "Probability"),+ #' @return Nothing if assertion passes, otherwise prints the error message. |
||
| 150 | +16 |
- ylim = NULL,+ #' |
||
| 151 | +17 |
- title = NULL,+ #' @name assertions |
||
| 152 | +18 |
- footnotes = NULL,+ NULL |
||
| 153 | +19 |
- font_size = 10,+ |
||
| 154 | +20 |
- ci_ribbon = FALSE,+ check_list_of_variables <- function(x) {
|
||
| 155 | +21 |
- annot_at_risk = TRUE,+ # drop NULL elements in list |
||
| 156 | -+ | |||
| 22 | +2957x |
- annot_at_risk_title = TRUE,+ x <- Filter(Negate(is.null), x) |
||
| 157 | +23 |
- annot_surv_med = TRUE,+ |
||
| 158 | -+ | |||
| 24 | +2957x |
- annot_coxph = FALSE,+ res <- checkmate::check_list(x, |
||
| 159 | -+ | |||
| 25 | +2957x |
- annot_stats = NULL,+ names = "named", |
||
| 160 | -+ | |||
| 26 | +2957x |
- annot_stats_vlines = FALSE,+ min.len = 1, |
||
| 161 | -+ | |||
| 27 | +2957x |
- control_coxph_pw = control_coxph(),+ any.missing = FALSE, |
||
| 162 | -+ | |||
| 28 | +2957x |
- ref_group_coxph = NULL,+ types = "character" |
||
| 163 | +29 |
- control_annot_surv_med = control_surv_med_annot(),+ ) |
||
| 164 | +30 |
- control_annot_coxph = control_coxph_annot(),+ # no empty strings allowed |
||
| 165 | -+ | |||
| 31 | +2957x |
- legend_pos = NULL,+ if (isTRUE(res)) {
|
||
| 166 | -+ | |||
| 32 | +2952x |
- rel_height_plot = 0.75,+ res <- checkmate::check_character(unlist(x), min.chars = 1) |
||
| 167 | +33 |
- ggtheme = NULL,+ } |
||
| 168 | -+ | |||
| 34 | +2957x |
- as_list = FALSE,+ return(res) |
||
| 169 | +35 |
- draw = lifecycle::deprecated(),+ } |
||
| 170 | +36 |
- newpage = lifecycle::deprecated(),+ #' @describeIn assertions Checks whether `x` is a valid list of variable names. |
||
| 171 | +37 |
- gp = lifecycle::deprecated(),+ #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`. |
||
| 172 | +38 |
- vp = lifecycle::deprecated(),+ #' |
||
| 173 | +39 |
- name = lifecycle::deprecated(),+ #' @keywords internal |
||
| 174 | +40 |
- annot_coxph_ref_lbls = lifecycle::deprecated(),+ assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables) |
||
| 175 | +41 |
- position_coxph = lifecycle::deprecated(),+ |
||
| 176 | +42 |
- position_surv_med = lifecycle::deprecated(),+ check_df_with_variables <- function(df, variables, na_level = NULL) {
|
||
| 177 | -+ | |||
| 43 | +2640x |
- width_annots = lifecycle::deprecated()) {
+ checkmate::assert_data_frame(df) |
||
| 178 | -+ | |||
| 44 | +2638x |
- # Deprecated argument warnings+ assert_list_of_variables(variables) |
||
| 179 | -10x | +|||
| 45 | +
- if (lifecycle::is_present(draw)) {
+
|
|||
| 180 | -1x | +|||
| 46 | +
- lifecycle::deprecate_warn(+ # flag for equal variables and column names |
|||
| 181 | -1x | +47 | +2636x |
- "0.9.4", "g_km(draw)",+ err_flag <- all(unlist(variables) %in% colnames(df)) |
| 182 | -1x | +48 | +2636x |
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ checkmate::assert_flag(err_flag) |
| 183 | +49 |
- )+ |
||
| 184 | -+ | |||
| 50 | +2636x |
- }+ if (isFALSE(err_flag)) {
|
||
| 185 | -10x | +51 | +5x |
- if (lifecycle::is_present(newpage)) {
+ vars <- setdiff(unlist(variables), colnames(df)) |
| 186 | -1x | +52 | +5x |
- lifecycle::deprecate_warn(+ return(paste( |
| 187 | -1x | +53 | +5x |
- "0.9.4", "g_km(newpage)",+ deparse(substitute(df)), |
| 188 | -1x | +54 | +5x |
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ "does not contain all specified variables as column names. Missing from data frame:",+ |
+
| 55 | +5x | +
+ paste(vars, collapse = ", ") |
||
| 189 | +56 |
- )+ )) |
||
| 190 | +57 |
} |
||
| 191 | -10x | +|||
| 58 | +
- if (lifecycle::is_present(gp)) {
+ # checking if na_level is present and in which column |
|||
| 192 | -1x | +59 | +2631x |
- lifecycle::deprecate_warn(+ if (!is.null(na_level)) {
|
| 193 | -1x | +60 | +9x |
- "0.9.4", "g_km(gp)",+ checkmate::assert_string(na_level) |
| 194 | -1x | +61 | +9x |
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level))) |
| 195 | -+ | |||
| 62 | +9x |
- )+ if (any(res)) {
|
||
| 196 | -+ | |||
| 63 | +1x |
- }+ return(paste0( |
||
| 197 | -10x | +64 | +1x |
- if (lifecycle::is_present(vp)) {
+ deparse(substitute(df)), " contains explicit na_level (", na_level,
|
| 198 | +65 | 1x |
- lifecycle::deprecate_warn(+ ") in the following columns: ", paste0(unlist(variables)[res], |
|
| 199 | +66 | 1x |
- "0.9.4", "g_km(vp)",+ collapse = ", " |
|
| 200 | -1x | +|||
| 67 | +
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ ) |
|||
| 201 | +68 |
- )+ )) |
||
| 202 | +69 |
- }+ } |
||
| 203 | -10x | +|||
| 70 | +
- if (lifecycle::is_present(name)) {
+ } |
|||
| 204 | -1x | +71 | +2630x |
- lifecycle::deprecate_warn(+ return(TRUE) |
| 205 | -1x | +|||
| 72 | +
- "0.9.4", "g_km(name)",+ } |
|||
| 206 | -1x | +|||
| 73 | +
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`. |
|||
| 207 | +74 |
- )+ #' Please notice how this produces an error when not all variables are present in the |
||
| 208 | +75 |
- }+ #' data.frame while the opposite is not required. |
||
| 209 | -10x | +|||
| 76 | +
- if (lifecycle::is_present(annot_coxph_ref_lbls)) {
+ #' |
|||
| 210 | -1x | +|||
| 77 | +
- lifecycle::deprecate_warn(+ #' @keywords internal |
|||
| 211 | -1x | +|||
| 78 | +
- "0.9.4", "g_km(annot_coxph_ref_lbls)",+ assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables) |
|||
| 212 | -1x | +|||
| 79 | +
- details = "Please specify this setting using the 'ref_lbls' element of control_annot_coxph."+ |
|||
| 213 | +80 |
- )+ check_valid_factor <- function(x, |
||
| 214 | -1x | +|||
| 81 | +
- control_annot_coxph[["ref_lbls"]] <- annot_coxph_ref_lbls+ min.levels = 1, # nolint |
|||
| 215 | +82 |
- }+ max.levels = NULL, # nolint |
||
| 216 | -10x | +|||
| 83 | +
- if (lifecycle::is_present(position_coxph)) {
+ null.ok = TRUE, # nolint |
|||
| 217 | -1x | +|||
| 84 | +
- lifecycle::deprecate_warn(+ any.missing = TRUE, # nolint |
|||
| 218 | -1x | +|||
| 85 | +
- "0.9.4", "g_km(position_coxph)",+ n.levels = NULL, # nolint |
|||
| 219 | -1x | +|||
| 86 | +
- details = "Please specify this setting using the 'x' and 'y' elements of control_annot_coxph."+ len = NULL) {
|
|||
| 220 | +87 |
- )+ # checks on levels insertion |
||
| 221 | -1x | +88 | +1111x |
- control_annot_coxph[["x"]] <- position_coxph[1]+ checkmate::assert_int(min.levels, lower = 1) |
| 222 | -1x | +|||
| 89 | +
- control_annot_coxph[["y"]] <- position_coxph[2]+ |
|||
| 223 | +90 |
- }+ # main factor check |
||
| 224 | -10x | +91 | +1111x |
- if (lifecycle::is_present(position_surv_med)) {
+ res <- checkmate::check_factor(x, |
| 225 | -1x | +92 | +1111x |
- lifecycle::deprecate_warn(+ min.levels = min.levels, |
| 226 | -1x | +93 | +1111x |
- "0.9.4", "g_km(position_surv_med)",+ null.ok = null.ok, |
| 227 | -1x | +94 | +1111x |
- details = "Please specify this setting using the 'x' and 'y' elements of control_annot_surv_med."+ max.levels = max.levels, |
| 228 | -+ | |||
| 95 | +1111x |
- )+ any.missing = any.missing, |
||
| 229 | -1x | +96 | +1111x |
- control_annot_surv_med[["x"]] <- position_surv_med[1]+ n.levels = n.levels |
| 230 | -1x | +|||
| 97 | +
- control_annot_surv_med[["y"]] <- position_surv_med[2]+ ) |
|||
| 231 | +98 |
- }+ |
||
| 232 | -10x | +|||
| 99 | +
- if (lifecycle::is_present(width_annots)) {
+ # no empty strings allowed |
|||
| 233 | -1x | +100 | +1111x |
- lifecycle::deprecate_warn(+ if (isTRUE(res)) {
|
| 234 | -1x | +101 | +1097x |
- "0.9.4", "g_km(width_annots)",+ res <- checkmate::check_character(levels(x), min.chars = 1) |
| 235 | -1x | +|||
| 102 | +
- details = paste(+ } |
|||
| 236 | -1x | +|||
| 103 | +
- "Please specify widths of annotation tables relative to the plot area using the 'w' element of",+ |
|||
| 237 | -1x | +104 | +1111x |
- "control_annot_surv_med (for surv_med) and control_annot_coxph (for coxph)."+ return(res) |
| 238 | +105 |
- )+ } |
||
| 239 | +106 |
- )+ #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty |
||
| 240 | -1x | +|||
| 107 | +
- control_annot_surv_med[["w"]] <- as.numeric(width_annots[["surv_med"]])+ #' string levels). Note that `NULL` and `NA` elements are allowed. |
|||
| 241 | -1x | +|||
| 108 | +
- control_annot_coxph[["w"]] <- as.numeric(width_annots[["coxph"]])+ #' |
|||
| 242 | +109 |
- }+ #' @keywords internal |
||
| 243 | +110 | - - | -||
| 244 | -10x | -
- checkmate::assert_list(variables)- |
- ||
| 245 | -10x | -
- checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
+ assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor) |
||
| 246 | -10x | +|||
| 111 | +
- checkmate::assert_logical(censor_show, len = 1)+ |
|||
| 247 | -10x | +|||
| 112 | +
- checkmate::assert_numeric(size, len = 1)+ check_df_with_factors <- function(df, |
|||
| 248 | -10x | +|||
| 113 | +
- checkmate::assert_numeric(max_time, len = 1, null.ok = TRUE)+ variables, |
|||
| 249 | -10x | +|||
| 114 | +
- checkmate::assert_numeric(xticks, null.ok = TRUE)+ min.levels = 1, # nolint |
|||
| 250 | -10x | +|||
| 115 | +
- checkmate::assert_character(xlab, len = 1, null.ok = TRUE)+ max.levels = NULL, # nolint |
|||
| 251 | -10x | +|||
| 116 | +
- checkmate::assert_character(yval)+ any.missing = TRUE, # nolint |
|||
| 252 | -10x | +|||
| 117 | +
- checkmate::assert_character(ylab, null.ok = TRUE)+ na_level = NULL) {
|
|||
| 253 | -10x | +118 | +254x |
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ res <- check_df_with_variables(df, variables, na_level) |
| 254 | -10x | +|||
| 119 | +
- checkmate::assert_character(title, len = 1, null.ok = TRUE)+ # checking if all the columns specified by variables are valid factors |
|||
| 255 | -10x | +120 | +253x |
- checkmate::assert_character(footnotes, len = 1, null.ok = TRUE)+ if (isTRUE(res)) {
|
| 256 | -10x | +|||
| 121 | +
- checkmate::assert_numeric(font_size, len = 1)+ # searching the data.frame with selected columns (variables) as a list |
|||
| 257 | -10x | +122 | +251x |
- checkmate::assert_logical(ci_ribbon, len = 1)+ res <- lapply( |
| 258 | -10x | +123 | +251x |
- checkmate::assert_logical(annot_at_risk, len = 1)+ X = as.list(df)[unlist(variables)], |
| 259 | -10x | +124 | +251x |
- checkmate::assert_logical(annot_at_risk_title, len = 1)+ FUN = check_valid_factor, |
| 260 | -10x | +125 | +251x |
- checkmate::assert_logical(annot_surv_med, len = 1)+ min.levels = min.levels, |
| 261 | -10x | +126 | +251x |
- checkmate::assert_logical(annot_coxph, len = 1)+ max.levels = max.levels, |
| 262 | -10x | +127 | +251x |
- checkmate::assert_subset(annot_stats, c("median", "min"))
+ any.missing = any.missing |
| 263 | -10x | +|||
| 128 | +
- checkmate::assert_logical(annot_stats_vlines)+ ) |
|||
| 264 | -10x | +129 | +251x |
- checkmate::assert_list(control_coxph_pw)+ res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1))) |
| 265 | -10x | +130 | +251x |
- checkmate::assert_character(ref_group_coxph, len = 1, null.ok = TRUE)+ if (any(res_lo)) {
|
| 266 | -10x | +131 | +6x |
- checkmate::assert_list(control_annot_surv_med)+ return(paste0( |
| 267 | -10x | +132 | +6x |
- checkmate::assert_list(control_annot_coxph)+ deparse(substitute(df)), " does not contain only factor variables among:", |
| 268 | -10x | +133 | +6x |
- checkmate::assert_numeric(legend_pos, finite = TRUE, any.missing = FALSE, len = 2, null.ok = TRUE)+ "\n* Column `", paste0(unlist(variables)[res_lo], |
| 269 | -10x | +134 | +6x |
- assert_proportion_value(rel_height_plot)+ "` of the data.frame -> ", res[res_lo], |
| 270 | -10x | +135 | +6x |
- checkmate::assert_logical(as_list)+ collapse = "\n* " |
| 271 | +136 | - - | -||
| 272 | -10x | -
- tte <- variables$tte- |
- ||
| 273 | -10x | -
- is_event <- variables$is_event+ ) |
||
| 274 | -10x | +|||
| 137 | +
- arm <- variables$arm+ )) |
|||
| 275 | -10x | +|||
| 138 | +
- assert_valid_factor(df[[arm]])+ } else {
|
|||
| 276 | -10x | +139 | +245x |
- armval <- as.character(unique(df[[arm]]))+ res <- TRUE |
| 277 | -10x | +|||
| 140 | +
- assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm))+ } |
|||
| 278 | -10x | +|||
| 141 | +
- checkmate::assert_logical(df[[is_event]], min.len = 1)+ } |
|||
| 279 | -10x | +142 | +247x |
- checkmate::assert_numeric(df[[tte]], min.len = 1)+ return(res) |
| 280 | -10x | +|||
| 143 | +
- checkmate::assert_vector(col, len = length(armval), null.ok = TRUE)+ } |
|||
| 281 | -10x | +|||
| 144 | +
- checkmate::assert_vector(lty, null.ok = TRUE)+ |
|||
| 282 | -10x | +|||
| 145 | +
- checkmate::assert_numeric(lwd, len = 1, null.ok = TRUE)+ #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables` |
|||
| 283 | +146 |
-
+ #' are all factors. Note that the creation of `NA` by direct call of `factor()` will |
||
| 284 | -10x | +|||
| 147 | +
- if (annot_coxph && length(armval) < 2) {
+ #' trim `NA` levels out of the vector list itself. |
|||
| 285 | -! | +|||
| 148 | +
- stop(paste(+ #' |
|||
| 286 | -! | +|||
| 149 | +
- "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`",+ #' @keywords internal |
|||
| 287 | -! | +|||
| 150 | +
- "in order to calculate the hazard ratio."+ assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors) |
|||
| 288 | +151 |
- ))+ |
||
| 289 | +152 |
- }+ #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1. |
||
| 290 | +153 |
-
+ #' |
||
| 291 | +154 |
- # process model+ #' @keywords internal |
||
| 292 | -10x | +|||
| 155 | +
- yval <- match.arg(yval)+ assert_proportion_value <- function(x, include_boundaries = FALSE) {
|
|||
| 293 | -10x | +156 | +14424x |
- formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
+ checkmate::assert_number(x, lower = 0, upper = 1) |
| 294 | -10x | +157 | +14412x |
- fit_km <- survival::survfit(+ checkmate::assert_flag(include_boundaries) |
| 295 | -10x | +158 | +14412x |
- formula = formula,+ if (isFALSE(include_boundaries)) {
|
| 296 | -10x | +159 | +8610x |
- data = df,+ checkmate::assert_true(x > 0) |
| 297 | -10x | +160 | +8608x |
- conf.int = control_surv$conf_level,+ checkmate::assert_true(x < 1) |
| 298 | -10x | +|||
| 161 | +
- conf.type = control_surv$conf_type+ } |
|||
| 299 | +162 |
- )+ } |
||
| 300 | -10x | +
| 1 | +
- data <- h_data_plot(fit_km, armval = armval, max_time = max_time)+ #' Individual patient plots |
||||
| 301 | +2 |
-
+ #' |
|||
| 302 | +3 |
- # calculate x-ticks+ #' @description `r lifecycle::badge("stable")`
|
|||
| 303 | -10x | +||||
| 4 | +
- xticks <- h_xticks(data = data, xticks = xticks, max_time = max_time)+ #' |
||||
| 304 | +5 |
-
+ #' Line plot(s) displaying trend in patients' parameter values over time is rendered. |
|||
| 305 | +6 |
- # change estimates of survival to estimates of failure (1 - survival)+ #' Patients' individual baseline values can be added to the plot(s) as reference. |
|||
| 306 | -10x | +||||
| 7 | +
- if (yval == "Failure") {
+ #' |
||||
| 307 | -! | +||||
| 8 | +
- data[c("estimate", "conf.low", "conf.high", "censor")] <- list(
+ #' @inheritParams argument_convention |
||||
| 308 | -! | +||||
| 9 | +
- 1 - data$estimate, 1 - data$conf.low, 1 - data$conf.high, 1 - data$censor+ #' @param xvar (`string`)\cr time point variable to be plotted on x-axis. |
||||
| 309 | +10 |
- )+ #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis. |
|||
| 310 | +11 |
- }+ #' @param xlab (`string`)\cr plot label for x-axis. |
|||
| 311 | +12 |
-
+ #' @param ylab (`string`)\cr plot label for y-axis. |
|||
| 312 | +13 |
- # derive y-axis limits+ #' @param id_var (`string`)\cr variable used as patient identifier. |
|||
| 313 | -10x | +||||
| 14 | +
- if (is.null(ylim)) {
+ #' @param title (`string`)\cr title for plot. |
||||
| 314 | -10x | +||||
| 15 | +
- if (!is.null(max_time)) {
+ #' @param subtitle (`string`)\cr subtitle for plot. |
||||
| 315 | -1x | +||||
| 16 | +
- y_lwr <- min(data[data$time < max_time, ][["estimate"]])+ #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on |
||||
| 316 | -1x | +||||
| 17 | +
- y_upr <- max(data[data$time < max_time, ][["estimate"]])+ #' plot when `TRUE`. |
||||
| 317 | +18 |
- } else {
+ #' @param yvar_baseline (`string`)\cr variable with baseline values only. |
|||
| 318 | -9x | +||||
| 19 | +
- y_lwr <- min(data[["estimate"]])+ #' Ignored when `add_baseline_hline` is `FALSE`. |
||||
| 319 | -9x | +||||
| 20 | +
- y_upr <- max(data[["estimate"]])+ #' @param ggtheme (`theme`)\cr optional graphical theme function as provided |
||||
| 320 | +21 |
- }+ #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display. |
|||
| 321 | -10x | +||||
| 22 | +
- ylim <- c(y_lwr, y_upr)+ #' @param plotting_choices (`string`)\cr specifies options for displaying |
||||
| 322 | +23 |
- }+ #' plots. Must be one of `"all_in_one"`, `"split_by_max_obs"`, or `"separate_by_obs"`. |
|||
| 323 | +24 |
-
+ #' @param max_obs_per_plot (`integer(1)`)\cr number of observations to be plotted on one |
|||
| 324 | +25 |
- # initialize ggplot+ #' plot. Ignored if `plotting_choices` is not `"separate_by_obs"`. |
|||
| 325 | -10x | +||||
| 26 | +
- gg_plt <- ggplot(+ #' @param caption (`string`)\cr optional caption below the plot. |
||||
| 326 | -10x | +||||
| 27 | +
- data = data,+ #' @param col (`character`)\cr line colors. |
||||
| 327 | -10x | +||||
| 28 | +
- mapping = aes(+ #' |
||||
| 328 | -10x | +||||
| 29 | +
- x = .data[["time"]],+ #' @seealso Relevant helper function [h_g_ipp()]. |
||||
| 329 | -10x | +||||
| 30 | +
- y = .data[["estimate"]],+ #' |
||||
| 330 | -10x | +||||
| 31 | +
- ymin = .data[["conf.low"]],+ #' @name g_ipp |
||||
| 331 | -10x | +||||
| 32 | +
- ymax = .data[["conf.high"]],+ #' @aliases individual_patient_plot |
||||
| 332 | -10x | +||||
| 33 | +
- color = .data[["strata"]],+ NULL |
||||
| 333 | -10x | +||||
| 34 | +
- fill = .data[["strata"]]+ |
||||
| 334 | +35 |
- )+ #' Helper function to create simple line plot over time |
|||
| 335 | +36 |
- ) ++ #' |
|||
| 336 | -10x | +||||
| 37 | +
- theme_bw(base_size = font_size) ++ #' @description `r lifecycle::badge("stable")`
|
||||
| 337 | -10x | +||||
| 38 | +
- scale_y_continuous(limits = ylim, expand = c(0.025, 0)) ++ #' |
||||
| 338 | -10x | +||||
| 39 | +
- labs(title = title, x = xlab, y = ylab, caption = footnotes) ++ #' Function that generates a simple line plot displaying parameter trends over time. |
||||
| 339 | -10x | +||||
| 40 | +
- theme(+ #' |
||||
| 340 | -10x | +||||
| 41 | +
- axis.text = element_text(size = font_size),+ #' @inheritParams argument_convention |
||||
| 341 | -10x | +||||
| 42 | +
- axis.title = element_text(size = font_size),+ #' @inheritParams g_ipp |
||||
| 342 | -10x | +||||
| 43 | +
- legend.title = element_blank(),+ #' |
||||
| 343 | -10x | +||||
| 44 | +
- legend.text = element_text(size = font_size),+ #' @return A `ggplot` line plot. |
||||
| 344 | -10x | +||||
| 45 | +
- legend.box.background = element_rect(fill = "white", linewidth = 0.5),+ #' |
||||
| 345 | -10x | +||||
| 46 | +
- legend.background = element_blank(),+ #' @seealso [g_ipp()] which uses this function. |
||||
| 346 | -10x | +||||
| 47 | +
- legend.position = "inside",+ #' |
||||
| 347 | -10x | +||||
| 48 | +
- legend.spacing.y = unit(-0.02, "npc"),+ #' @examples |
||||
| 348 | -10x | +||||
| 49 | +
- panel.grid.major = element_blank(),+ #' library(dplyr) |
||||
| 349 | -10x | +||||
| 50 | +
- panel.grid.minor = element_blank()+ #' |
||||
| 350 | +51 |
- )+ #' # Select a small sample of data to plot. |
|||
| 351 | +52 |
-
+ #' adlb <- tern_ex_adlb %>% |
|||
| 352 | +53 |
- # derive x-axis limits+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
|||
| 353 | -10x | +||||
| 54 | +
- if (!is.null(max_time) && !is.null(xticks)) {
+ #' slice(1:36) |
||||
| 354 | -1x | +||||
| 55 | +
- gg_plt <- gg_plt + scale_x_continuous(+ #' |
||||
| 355 | -1x | +||||
| 56 | +
- breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))), expand = c(0.025, 0)+ #' p <- h_g_ipp( |
||||
| 356 | +57 |
- )+ #' df = adlb, |
|||
| 357 | -9x | +||||
| 58 | +
- } else if (!is.null(xticks)) {
+ #' xvar = "AVISIT", |
||||
| 358 | -9x | +||||
| 59 | +
- if (max(data$time) <= max(xticks)) {
+ #' yvar = "AVAL", |
||||
| 359 | -9x | +||||
| 60 | +
- gg_plt <- gg_plt + scale_x_continuous(+ #' xlab = "Visit", |
||||
| 360 | -9x | +||||
| 61 | +
- breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)), expand = c(0.025, 0)+ #' id_var = "USUBJID", |
||||
| 361 | +62 |
- )+ #' ylab = "SGOT/ALT (U/L)", |
|||
| 362 | +63 |
- } else {
+ #' add_baseline_hline = TRUE |
|||
| 363 | -! | +||||
| 64 | +
- gg_plt <- gg_plt + scale_x_continuous(breaks = xticks, expand = c(0.025, 0))+ #' ) |
||||
| 364 | +65 |
- }+ #' p |
|||
| 365 | -! | +||||
| 66 | +
- } else if (!is.null(max_time)) {
+ #' |
||||
| 366 | -! | +||||
| 67 | +
- gg_plt <- gg_plt + scale_x_continuous(limits = c(0, max_time), expand = c(0.025, 0))+ #' @export |
||||
| 367 | +68 |
- }+ h_g_ipp <- function(df, |
|||
| 368 | +69 |
-
+ xvar, |
|||
| 369 | +70 |
- # set legend position+ yvar, |
|||
| 370 | -10x | +||||
| 71 | +
- if (!is.null(legend_pos)) {
+ xlab, |
||||
| 371 | -2x | +||||
| 72 | +
- gg_plt <- gg_plt + theme(legend.position.inside = legend_pos)+ ylab, |
||||
| 372 | +73 |
- } else {
+ id_var, |
|||
| 373 | -8x | +||||
| 74 | +
- max_time2 <- sort(+ title = "Individual Patient Plots", |
||||
| 374 | -8x | +||||
| 75 | +
- data$time,+ subtitle = "", |
||||
| 375 | -8x | +||||
| 76 | +
- partial = nrow(data) - length(armval) - 1+ caption = NULL, |
||||
| 376 | -8x | +||||
| 77 | +
- )[nrow(data) - length(armval) - 1]+ add_baseline_hline = FALSE, |
||||
| 377 | +78 |
-
+ yvar_baseline = "BASE", |
|||
| 378 | -8x | +||||
| 79 | +
- y_rng <- ylim[2] - ylim[1]+ ggtheme = nestcolor::theme_nest(), |
||||
| 379 | +80 |
-
+ col = NULL) {
|
|||
| 380 | -8x | +81 | +13x |
- if (yval == "Survival" && all(data$estimate[data$time == max_time2] > ylim[1] + 0.09 * y_rng) &&+ checkmate::assert_string(xvar) |
|
| 381 | -8x | +82 | +13x |
- all(data$estimate[data$time == max_time2] < ylim[1] + 0.5 * y_rng)) { # nolint
+ checkmate::assert_string(yvar) |
|
| 382 | -1x | +83 | +13x |
- gg_plt <- gg_plt ++ checkmate::assert_string(yvar_baseline) |
|
| 383 | -1x | +84 | +13x |
- theme(+ checkmate::assert_string(id_var) |
|
| 384 | -1x | +85 | +13x |
- legend.position.inside = c(1, 0.5),+ checkmate::assert_string(xlab) |
|
| 385 | -1x | +86 | +13x |
- legend.justification = c(1.1, 0.6)+ checkmate::assert_string(ylab) |
|
| 386 | -+ | ||||
| 87 | +13x |
- )+ checkmate::assert_string(title) |
|||
| 387 | -+ | ||||
| 88 | +13x |
- } else {
+ checkmate::assert_string(subtitle) |
|||
| 388 | -7x | +89 | +13x |
- gg_plt <- gg_plt ++ checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df)) |
|
| 389 | -7x | +90 | +13x |
- theme(+ checkmate::assert_data_frame(df) |
|
| 390 | -7x | +91 | +13x |
- legend.position.inside = c(1, 0),+ checkmate::assert_flag(add_baseline_hline) |
|
| 391 | -7x | +92 | +13x |
- legend.justification = c(1.1, -0.4)+ checkmate::assert_character(col, null.ok = TRUE) |
|
| 392 | +93 |
- )+ |
|||
| 393 | -+ | ||||
| 94 | +13x |
- }+ p <- ggplot2::ggplot( |
|||
| 394 | -+ | ||||
| 95 | +13x |
- }+ data = df, |
|||
| 395 | -+ | ||||
| 96 | +13x |
-
+ mapping = ggplot2::aes( |
|||
| 396 | -+ | ||||
| 97 | +13x |
- # add lines+ x = .data[[xvar]], |
|||
| 397 | -10x | -
- gg_plt <- if (is.null(lty)) {
+ | 98 | +13x | +
+ y = .data[[yvar]], |
| 398 | -9x | +99 | +13x |
- gg_plt + geom_step(linewidth = lwd, na.rm = TRUE)+ group = .data[[id_var]], |
|
| 399 | -10x | +100 | +13x |
- } else if (length(lty) == 1) {
+ colour = .data[[id_var]] |
|
| 400 | -! | +||||
| 101 | +
- gg_plt + geom_step(linewidth = lwd, lty = lty, na.rm = TRUE)+ ) |
||||
| 401 | +102 |
- } else {
+ ) + |
|||
| 402 | -1x | +103 | +13x |
- gg_plt ++ ggplot2::geom_line(linewidth = 0.4) + |
|
| 403 | -1x | +104 | +13x |
- geom_step(aes(lty = .data[["strata"]]), linewidth = lwd, na.rm = TRUE) ++ ggplot2::geom_point(size = 2) + |
|
| 404 | -1x | -
- scale_linetype_manual(values = lty)- |
- |||
| 405 | -- |
- }- |
- |||
| 406 | -+ | 105 | +13x |
-
+ ggplot2::labs( |
|
| 407 | -+ | ||||
| 106 | +13x |
- # add censor marks+ x = xlab, |
|||
| 408 | -10x | +107 | +13x |
- if (censor_show) {
+ y = ylab, |
|
| 409 | -10x | +108 | +13x |
- gg_plt <- gg_plt + geom_point(+ title = title, |
|
| 410 | -10x | +109 | +13x |
- data = data[data$n.censor != 0, ],+ subtitle = subtitle, |
|
| 411 | -10x | +110 | +13x |
- aes(x = .data[["time"]], y = .data[["censor"]], shape = "Censored"),+ caption = caption |
|
| 412 | -10x | +||||
| 111 | +
- size = size,+ ) + |
||||
| 413 | -10x | +112 | +13x |
- na.rm = TRUE+ ggtheme |
|
| 414 | +113 |
- ) ++ |
|||
| 415 | -10x | +114 | +13x |
- scale_shape_manual(name = NULL, values = pch) ++ if (add_baseline_hline) {
|
|
| 416 | -10x | +115 | +12x |
- guides(fill = guide_legend(override.aes = list(shape = NA)))+ baseline_df <- df[, c(id_var, yvar_baseline)] |
|
| 417 | -+ | ||||
| 116 | +12x |
- }+ baseline_df <- unique(baseline_df) |
|||
| 418 | +117 | ||||
| 419 | -- |
- # add ci ribbon- |
- |||
| 420 | -1x | -
- if (ci_ribbon) gg_plt <- gg_plt + geom_ribbon(alpha = 0.3, lty = 0, na.rm = TRUE)- |
- |||
| 421 | -+ | 118 | +12x |
-
+ p <- p + |
|
| 422 | -+ | ||||
| 119 | +12x |
- # control aesthetics+ ggplot2::geom_hline( |
|||
| 423 | -10x | +120 | +12x |
- if (!is.null(col)) {
+ data = baseline_df, |
|
| 424 | -1x | +121 | +12x |
- gg_plt <- gg_plt ++ mapping = ggplot2::aes( |
|
| 425 | -1x | +122 | +12x |
- scale_color_manual(values = col) ++ yintercept = .data[[yvar_baseline]], |
|
| 426 | -1x | +123 | +12x |
- scale_fill_manual(values = col)+ colour = .data[[id_var]] |
|
| 427 | +124 |
- }+ ), |
|||
| 428 | -! | +||||
| 125 | +12x |
- if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ linetype = "dotdash", |
|||
| 429 | -+ | ||||
| 126 | +12x |
-
+ linewidth = 0.4 |
|||
| 430 | +127 |
- # annotate with stats (text/vlines)+ ) + |
|||
| 431 | -10x | +128 | +12x |
- if (!is.null(annot_stats)) {
+ ggplot2::geom_text( |
|
| 432 | -! | +||||
| 129 | +12x |
- if ("median" %in% annot_stats) {
+ data = baseline_df, |
|||
| 433 | -! | +||||
| 130 | +12x |
- fit_km_all <- survival::survfit(+ mapping = ggplot2::aes( |
|||
| 434 | -! | +||||
| 131 | +12x |
- formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
+ x = 1, |
|||
| 435 | -! | +||||
| 132 | +12x |
- data = df,+ y = .data[[yvar_baseline]], |
|||
| 436 | -! | +||||
| 133 | +12x |
- conf.int = control_surv$conf_level,+ label = .data[[id_var]], |
|||
| 437 | -! | +||||
| 134 | +12x |
- conf.type = control_surv$conf_type+ colour = .data[[id_var]] |
|||
| 438 | +135 |
- )- |
- |||
| 439 | -! | -
- gg_plt <- gg_plt +- |
- |||
| 440 | -! | -
- annotate(- |
- |||
| 441 | -! | -
- "text",+ ), |
|||
| 442 | -! | +||||
| 136 | +12x |
- size = font_size / .pt, col = 1, lineheight = 0.95,+ nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)), |
|||
| 443 | -! | +||||
| 137 | +12x |
- x = stats::median(fit_km_all) + 0.07 * max(data$time),+ vjust = "right", |
|||
| 444 | -! | +||||
| 138 | +12x |
- y = ifelse(yval == "Survival", 0.65, 0.35),+ size = 2 |
|||
| 445 | -! | +||||
| 139 | +
- label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
+ ) |
||||
| 446 | +140 |
- )+ |
|||
| 447 | -! | +||||
| 141 | +12x |
- if (annot_stats_vlines) {
+ if (!is.null(col)) {
|
|||
| 448 | -! | +||||
| 142 | +1x |
- gg_plt <- gg_plt ++ p <- p + |
|||
| 449 | -! | +||||
| 143 | +1x |
- annotate(+ ggplot2::scale_color_manual(values = col) |
|||
| 450 | -! | +||||
| 144 | +
- "segment",+ } |
||||
| 451 | -! | +||||
| 145 | +
- x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf,+ } |
||||
| 452 | -! | +||||
| 146 | +13x |
- linetype = 2, col = "darkgray"+ p |
|||
| 453 | +147 |
- )+ } |
|||
| 454 | +148 |
- }+ |
|||
| 455 | +149 |
- }- |
- |||
| 456 | -! | -
- if ("min" %in% annot_stats) {
- |
- |||
| 457 | -! | -
- min_fu <- min(df[[tte]])- |
- |||
| 458 | -! | -
- gg_plt <- gg_plt +- |
- |||
| 459 | -! | -
- annotate(+ #' @describeIn g_ipp Plotting function for individual patient plots which, depending on user |
|||
| 460 | -! | +||||
| 150 | +
- "text",+ #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter |
||||
| 461 | -! | +||||
| 151 | +
- size = font_size / .pt, col = 1, lineheight = 0.95,+ #' values over time. |
||||
| 462 | -! | +||||
| 152 | +
- x = min_fu + max(data$time) * 0.07,+ #' |
||||
| 463 | -! | +||||
| 153 | +
- y = ifelse(yval == "Survival", 0.96, 0.05),+ #' @return A `ggplot` object or a list of `ggplot` objects. |
||||
| 464 | -! | +||||
| 154 | +
- label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
+ #' |
||||
| 465 | +155 |
- )+ #' @examples |
|||
| 466 | -! | +||||
| 156 | +
- if (annot_stats_vlines) {
+ #' library(dplyr) |
||||
| 467 | -! | +||||
| 157 | +
- gg_plt <- gg_plt ++ #' |
||||
| 468 | -! | +||||
| 158 | +
- annotate(+ #' # Select a small sample of data to plot. |
||||
| 469 | -! | +||||
| 159 | +
- "segment",+ #' adlb <- tern_ex_adlb %>% |
||||
| 470 | -! | +||||
| 160 | +
- linetype = 2, col = "darkgray",+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
||||
| 471 | -! | +||||
| 161 | +
- x = min_fu, xend = min_fu, y = Inf, yend = -Inf+ #' slice(1:36) |
||||
| 472 | +162 |
- )+ #' |
|||
| 473 | +163 |
- }+ #' plot_list <- g_ipp( |
|||
| 474 | +164 |
- }+ #' df = adlb, |
|||
| 475 | -! | +||||
| 165 | +
- gg_plt <- gg_plt + guides(fill = guide_legend(override.aes = list(shape = NA, label = "")))+ #' xvar = "AVISIT", |
||||
| 476 | +166 |
- }+ #' yvar = "AVAL", |
|||
| 477 | +167 |
-
+ #' xlab = "Visit", |
|||
| 478 | +168 |
- # add at risk annotation table+ #' ylab = "SGOT/ALT (U/L)", |
|||
| 479 | -10x | +||||
| 169 | +
- if (annot_at_risk) {
+ #' title = "Individual Patient Plots", |
||||
| 480 | -9x | +||||
| 170 | +
- annot_tbl <- summary(fit_km, times = xticks, extend = TRUE)+ #' add_baseline_hline = TRUE, |
||||
| 481 | -9x | +||||
| 171 | +
- annot_tbl <- if (is.null(fit_km$strata)) {
+ #' plotting_choices = "split_by_max_obs", |
||||
| 482 | -! | +||||
| 172 | +
- data.frame(+ #' max_obs_per_plot = 5 |
||||
| 483 | -! | +||||
| 173 | +
- n.risk = annot_tbl$n.risk,+ #' ) |
||||
| 484 | -! | +||||
| 174 | +
- time = annot_tbl$time,+ #' plot_list |
||||
| 485 | -! | +||||
| 175 | +
- strata = armval+ #' |
||||
| 486 | +176 |
- )+ #' @export |
|||
| 487 | +177 |
- } else {
+ g_ipp <- function(df, |
|||
| 488 | -9x | +||||
| 178 | +
- strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ xvar, |
||||
| 489 | -9x | +||||
| 179 | +
- levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ yvar, |
||||
| 490 | -9x | +||||
| 180 | +
- data.frame(+ xlab, |
||||
| 491 | -9x | +||||
| 181 | +
- n.risk = annot_tbl$n.risk,+ ylab, |
||||
| 492 | -9x | +||||
| 182 | +
- time = annot_tbl$time,+ id_var = "USUBJID", |
||||
| 493 | -9x | +||||
| 183 | +
- strata = annot_tbl$strata+ title = "Individual Patient Plots", |
||||
| 494 | +184 |
- )+ subtitle = "", |
|||
| 495 | +185 |
- }+ caption = NULL, |
|||
| 496 | +186 |
-
+ add_baseline_hline = FALSE, |
|||
| 497 | -9x | +||||
| 187 | +
- at_risk_tbl <- as.data.frame(tidyr::pivot_wider(annot_tbl, names_from = "time", values_from = "n.risk")[, -1])+ yvar_baseline = "BASE", |
||||
| 498 | -9x | +||||
| 188 | +
- at_risk_tbl[is.na(at_risk_tbl)] <- 0+ ggtheme = nestcolor::theme_nest(), |
||||
| 499 | -9x | +||||
| 189 | +
- rownames(at_risk_tbl) <- levels(annot_tbl$strata)+ plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
|
||||
| 500 | +190 |
-
+ max_obs_per_plot = 4, |
|||
| 501 | -9x | +||||
| 191 | +
- gg_at_risk <- df2gg(+ col = NULL) {
|
||||
| 502 | -9x | +192 | +3x |
- at_risk_tbl,+ checkmate::assert_count(max_obs_per_plot) |
|
| 503 | -9x | +193 | +3x |
- font_size = font_size, col_labels = FALSE, hline = FALSE,+ checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
|
|
| 504 | -9x | +194 | +3x |
- colwidths = rep(1, ncol(at_risk_tbl))+ checkmate::assert_character(col, null.ok = TRUE) |
|
| 505 | +195 |
- ) ++ |
|||
| 506 | -9x | +196 | +3x |
- labs(title = if (annot_at_risk_title) "Patients at Risk:" else NULL, x = xlab) ++ plotting_choices <- match.arg(plotting_choices) |
|
| 507 | -9x | +||||
| 197 | +
- theme_bw(base_size = font_size) ++ |
||||
| 508 | -9x | +198 | +3x |
- theme(+ if (plotting_choices == "all_in_one") {
|
|
| 509 | -9x | +199 | +1x |
- plot.title = element_text(size = font_size, vjust = 3, face = "bold"),+ p <- h_g_ipp( |
|
| 510 | -9x | +200 | +1x |
- panel.border = element_blank(),+ df = df, |
|
| 511 | -9x | +201 | +1x |
- panel.grid = element_blank(),+ xvar = xvar, |
|
| 512 | -9x | +202 | +1x |
- axis.title.y = element_blank(),+ yvar = yvar, |
|
| 513 | -9x | +203 | +1x |
- axis.ticks.y = element_blank(),+ xlab = xlab, |
|
| 514 | -9x | +204 | +1x |
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ ylab = ylab, |
|
| 515 | -9x | +205 | +1x |
- axis.text.x = element_text(size = font_size),+ id_var = id_var, |
|
| 516 | -9x | +206 | +1x |
- axis.line.x = element_line()+ title = title, |
|
| 517 | -+ | ||||
| 207 | +1x |
- ) ++ subtitle = subtitle, |
|||
| 518 | -9x | +208 | +1x |
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(at_risk_tbl)))+ caption = caption, |
|
| 519 | -9x | +209 | +1x |
- gg_at_risk <- suppressMessages(+ add_baseline_hline = add_baseline_hline, |
|
| 520 | -9x | +210 | +1x |
- gg_at_risk ++ yvar_baseline = yvar_baseline, |
|
| 521 | -9x | +211 | +1x |
- scale_x_continuous(expand = c(0.025, 0), breaks = seq_along(at_risk_tbl) - 0.5, labels = xticks) ++ ggtheme = ggtheme, |
|
| 522 | -9x | +212 | +1x |
- scale_y_continuous(labels = rev(levels(annot_tbl$strata)), breaks = seq_len(nrow(at_risk_tbl)))+ col = col |
|
| 523 | +213 |
) |
|||
| 524 | +214 | ||||
| 525 | -9x | +215 | +1x |
- if (!as_list) {
+ return(p) |
|
| 526 | -8x | +216 | +2x |
- gg_plt <- cowplot::plot_grid(+ } else if (plotting_choices == "split_by_max_obs") {
|
|
| 527 | -8x | +217 | +1x |
- gg_plt,+ id_vec <- unique(df[[id_var]]) |
|
| 528 | -8x | +218 | +1x |
- gg_at_risk,+ id_list <- split( |
|
| 529 | -8x | +219 | +1x |
- align = "v",+ id_vec, |
|
| 530 | -8x | +220 | +1x |
- axis = "tblr",+ rep(1:ceiling(length(id_vec) / max_obs_per_plot), |
|
| 531 | -8x | +221 | +1x |
- ncol = 1,+ each = max_obs_per_plot, |
|
| 532 | -8x | +222 | +1x |
- rel_heights = c(rel_height_plot, 1 - rel_height_plot)+ length.out = length(id_vec) |
|
| 533 | +223 |
) |
|||
| 534 | +224 |
- }+ ) |
|||
| 535 | +225 |
- }+ + |
+ |||
| 226 | +1x | +
+ df_list <- list()+ |
+ |||
| 227 | +1x | +
+ plot_list <- list() |
|||
| 536 | +228 | ||||
| 229 | +1x | +
+ for (i in seq_along(id_list)) {
+ |
+ |||
| 230 | +2x | +
+ df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ]+ |
+ |||
| 537 | +231 |
- # add median survival time annotation table+ |
|||
| 538 | -10x | +232 | +2x |
- if (annot_surv_med) {
+ plots <- h_g_ipp( |
|
| 539 | -8x | +233 | +2x |
- surv_med_tbl <- h_tbl_median_surv(fit_km = fit_km, armval = armval)+ df = df_list[[i]], |
|
| 540 | -8x | +234 | +2x |
- bg_fill <- if (isTRUE(control_annot_surv_med[["fill"]])) "#00000020" else control_annot_surv_med[["fill"]]+ xvar = xvar, |
|
| 541 | -+ | ||||
| 235 | +2x |
-
+ yvar = yvar, |
|||
| 542 | -8x | +236 | +2x |
- gg_surv_med <- df2gg(surv_med_tbl, font_size = font_size, colwidths = c(1, 1, 2), bg_fill = bg_fill) ++ xlab = xlab, |
|
| 543 | -8x | +237 | +2x |
- theme(+ ylab = ylab, |
|
| 544 | -8x | +238 | +2x |
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ id_var = id_var, |
|
| 545 | -8x | +239 | +2x |
- plot.margin = margin(0, 2, 0, 5)+ title = title, |
|
| 546 | -+ | ||||
| 240 | +2x |
- ) ++ subtitle = subtitle, |
|||
| 547 | -8x | +241 | +2x |
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(surv_med_tbl) + 1.5))+ caption = caption, |
|
| 548 | -8x | +242 | +2x |
- gg_surv_med <- suppressMessages(+ add_baseline_hline = add_baseline_hline, |
|
| 549 | -8x | +243 | +2x |
- gg_surv_med ++ yvar_baseline = yvar_baseline, |
|
| 550 | -8x | +244 | +2x |
- scale_x_continuous(expand = c(0.025, 0)) ++ ggtheme = ggtheme, |
|
| 551 | -8x | +245 | +2x |
- scale_y_continuous(labels = rev(rownames(surv_med_tbl)), breaks = seq_len(nrow(surv_med_tbl)))+ col = col |
|
| 552 | +246 |
- )+ ) |
|||
| 553 | +247 | ||||
| 554 | -8x | +248 | +2x |
- gg_plt <- cowplot::ggdraw(gg_plt) +- |
- |
| 555 | -8x | -
- cowplot::draw_plot(- |
- |||
| 556 | -8x | -
- gg_surv_med,- |
- |||
| 557 | -8x | -
- control_annot_surv_med[["x"]],- |
- |||
| 558 | -8x | -
- control_annot_surv_med[["y"]],- |
- |||
| 559 | -8x | -
- width = control_annot_surv_med[["w"]],- |
- |||
| 560 | -8x | -
- height = control_annot_surv_med[["h"]],- |
- |||
| 561 | -8x | -
- vjust = 0.5,- |
- |||
| 562 | -8x | -
- hjust = 0.5- |
- |||
| 563 | -- |
- )- |
- |||
| 564 | -- |
- }- |
- |||
| 565 | -- | - - | -|||
| 566 | -- |
- # add coxph annotation table- |
- |||
| 567 | -10x | -
- if (annot_coxph) {
- |
- |||
| 568 | -1x | -
- coxph_tbl <- h_tbl_coxph_pairwise(- |
- |||
| 569 | -1x | -
- df = df,- |
- |||
| 570 | -1x | -
- variables = variables,- |
- |||
| 571 | -1x | -
- ref_group_coxph = ref_group_coxph,- |
- |||
| 572 | -1x | -
- control_coxph_pw = control_coxph_pw,- |
- |||
| 573 | -1x | -
- annot_coxph_ref_lbls = control_annot_coxph[["ref_lbls"]]+ plot_list[[i]] <- plots |
|||
| 574 | +249 |
- )+ } |
|||
| 575 | +250 | 1x |
- bg_fill <- if (isTRUE(control_annot_coxph[["fill"]])) "#00000020" else control_annot_coxph[["fill"]]+ return(plot_list) |
||
| 576 | +251 |
-
+ } else {
|
|||
| 577 | +252 | 1x |
- gg_coxph <- df2gg(coxph_tbl, font_size = font_size, colwidths = c(1.1, 1, 3), bg_fill = bg_fill) ++ ind_df <- split(df, df[[id_var]]) |
||
| 578 | +253 | 1x |
- theme(+ plot_list <- lapply( |
||
| 579 | +254 | 1x |
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ ind_df, |
||
| 580 | +255 | 1x |
- plot.margin = margin(0, 2, 0, 5)- |
- ||
| 581 | -- |
- ) ++ function(x) {
|
|||
| 582 | -1x | +256 | +8x |
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(coxph_tbl) + 1.5))+ h_g_ipp( |
|
| 583 | -1x | +257 | +8x |
- gg_coxph <- suppressMessages(+ df = x, |
|
| 584 | -1x | +258 | +8x |
- gg_coxph ++ xvar = xvar, |
|
| 585 | -1x | +259 | +8x |
- scale_x_continuous(expand = c(0.025, 0)) ++ yvar = yvar, |
|
| 586 | -1x | -
- scale_y_continuous(labels = rev(rownames(coxph_tbl)), breaks = seq_len(nrow(coxph_tbl)))- |
- |||
| 587 | -- |
- )- |
- |||
| 588 | -+ | 260 | +8x |
-
+ xlab = xlab, |
|
| 589 | -1x | +261 | +8x |
- gg_plt <- cowplot::ggdraw(gg_plt) ++ ylab = ylab, |
|
| 590 | -1x | +262 | +8x |
- cowplot::draw_plot(+ id_var = id_var, |
|
| 591 | -1x | +263 | +8x |
- gg_coxph,+ title = title, |
|
| 592 | -1x | +264 | +8x |
- control_annot_coxph[["x"]],+ subtitle = subtitle, |
|
| 593 | -1x | +265 | +8x |
- control_annot_coxph[["y"]],+ caption = caption, |
|
| 594 | -1x | +266 | +8x |
- width = control_annot_coxph[["w"]],+ add_baseline_hline = add_baseline_hline, |
|
| 595 | -1x | +267 | +8x |
- height = control_annot_coxph[["h"]],+ yvar_baseline = yvar_baseline, |
|
| 596 | -1x | +268 | +8x |
- vjust = 0.5,+ ggtheme = ggtheme, |
|
| 597 | -1x | +269 | +8x |
- hjust = 0.5+ col = col |
|
| 598 | +270 |
- )+ ) |
|||
| 599 | +271 |
- }+ } |
|||
| 600 | +272 | - - | -|||
| 601 | -10x | -
- if (as_list) {
- |
- |||
| 602 | -1x | -
- list(plot = gg_plt, table = gg_at_risk)+ ) |
|||
| 603 | +273 |
- } else {
+
|
|||
| 604 | -9x | +274 | +1x |
- gg_plt+ return(plot_list) |
|
| 605 | +275 |
} |
|||
| 606 | +276 |
}@@ -170250,14 +169010,14 @@ tern coverage - 95.65% |
| 1 |
- #' Convert `rtable` objects to `ggplot` objects+ #' Occurrence table sorting |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using+ #' Functions to score occurrence table subtables and rows which can be used in the |
||
| 6 |
- #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored.+ #' sorting of occurrence tables. |
||
| 8 |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ #' @name score_occurrences |
||
| 9 |
- #' @param fontsize (`numeric(1)`)\cr font size.+ NULL |
||
| 10 |
- #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in+ |
||
| 11 |
- #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths+ #' @describeIn score_occurrences Scoring function which sums the counts across all |
||
| 12 |
- #' are calculated according to maximum number of characters per column.+ #' columns. It will fail if anything else but counts are used. |
||
| 13 |
- #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between+ #' |
||
| 14 |
- #' the first (label) column and the second column of `tbl`. If `colwidths` is specified,+ #' @inheritParams rtables_access |
||
| 15 |
- #' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0.+ #' |
||
| 16 |
- #'+ #' @return |
||
| 17 |
- #' @return A `ggplot` object.+ #' * `score_occurrences()` returns the sum of counts across all columns of a table row. |
||
| 19 |
- #' @examples+ #' @seealso [h_row_first_values()] |
||
| 20 |
- #' dta <- data.frame(+ #' |
||
| 21 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' @examples |
||
| 22 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' lyt <- basic_table() %>% |
||
| 23 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' split_cols_by("ARM") %>%
|
||
| 24 |
- #' )+ #' add_colcounts() %>% |
||
| 25 |
- #'+ #' analyze_num_patients( |
||
| 26 |
- #' lyt <- basic_table() %>%+ #' vars = "USUBJID", |
||
| 27 |
- #' split_cols_by(var = "ARM") %>%+ #' .stats = c("unique"),
|
||
| 28 |
- #' split_rows_by(var = "AVISIT") %>%+ #' .labels = c("Total number of patients with at least one event")
|
||
| 29 |
- #' analyze_vars(vars = "AVAL")+ #' ) %>% |
||
| 30 |
- #'+ #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
|
||
| 31 |
- #' tbl <- build_table(lyt, df = dta)+ #' summarize_num_patients( |
||
| 32 |
- #'+ #' var = "USUBJID", |
||
| 33 |
- #' rtable2gg(tbl)+ #' .stats = c("unique", "nonunique"),
|
||
| 34 |
- #'+ #' .labels = c( |
||
| 35 |
- #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1))+ #' "Total number of patients with at least one event", |
||
| 36 |
- #'+ #' "Total number of events" |
||
| 37 |
- #' @export+ #' ) |
||
| 38 |
- rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
+ #' ) %>% |
||
| 39 | -6x | +
- mat <- rtables::matrix_form(tbl, indent_rownames = TRUE)+ #' count_occurrences(vars = "AEDECOD") |
|
| 40 | -6x | +
- mat_strings <- formatters::mf_strings(mat)+ #' |
|
| 41 | -6x | +
- mat_aligns <- formatters::mf_aligns(mat)+ #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>% |
|
| 42 | -6x | +
- mat_indent <- formatters::mf_rinfo(mat)$indent+ #' prune_table() |
|
| 43 | -6x | +
- mat_display <- formatters::mf_display(mat)+ #' |
|
| 44 | -6x | +
- nlines_hdr <- formatters::mf_nlheader(mat)+ #' tbl_sorted <- tbl %>% |
|
| 45 | -6x | +
- shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x))))+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
|
|
| 46 |
-
+ #' |
||
| 47 | -6x | +
- tbl_df <- data.frame(mat_strings)+ #' tbl_sorted |
|
| 48 | -6x | +
- body_rows <- seq(nlines_hdr + 1, nrow(tbl_df))+ #' |
|
| 49 | -6x | +
- mat_aligns <- apply(mat_aligns, 1:2, function(x) if (x == "left") 0 else if (x == "right") 1 else 0.5)+ #' @export |
|
| 50 |
-
+ score_occurrences <- function(table_row) {
|
||
| 51 | -+ | 37x |
- # Apply indentation in first column+ row_counts <- h_row_counts(table_row) |
| 52 | -6x | +37x |
- tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
+ sum(row_counts) |
| 53 | -42x | +
- ind_i <- mat_indent[i - nlines_hdr] * 4+ } |
|
| 54 | -18x | +
- if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1]
+
|
|
| 55 |
- })+ #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include |
||
| 56 |
-
+ #' specific columns in the scoring. See [h_row_counts()] for further information. |
||
| 57 |
- # Get column widths+ #' |
||
| 58 | -6x | +
- if (is.null(colwidths)) {
+ #' @inheritParams has_count_in_cols |
|
| 59 | -6x | +
- colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1+ #' |
|
| 60 |
- }+ #' @return |
||
| 61 | -6x | +
- tot_width <- sum(colwidths) + lbl_col_padding+ #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns |
|
| 62 |
-
+ #' of a table row. |
||
| 63 | -6x | +
- if (length(shared_hdr_rows) > 0) {
+ #' |
|
| 64 | -5x | +
- tbl_df <- tbl_df[-shared_hdr_rows, ]+ #' @seealso [h_row_counts()] |
|
| 65 | -5x | +
- mat_aligns <- mat_aligns[-shared_hdr_rows, ]+ #' |
|
| 66 |
- }+ #' @examples |
||
| 67 |
-
+ #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
|
||
| 68 | -6x | +
- res <- ggplot(data = tbl_df) ++ #' |
|
| 69 | -6x | +
- theme_void() ++ #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted. |
|
| 70 | -6x | +
- scale_x_continuous(limits = c(0, tot_width)) ++ #' # That would require a second pass of `sort_at_path`. |
|
| 71 | -6x | +
- scale_y_continuous(limits = c(0, nrow(mat_strings))) ++ #' tbl_sorted <- tbl %>% |
|
| 72 | -6x | +
- annotate(+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
|
|
| 73 | -6x | +
- "segment",+ #' |
|
| 74 | -6x | +
- x = 0, xend = tot_width,+ #' tbl_sorted |
|
| 75 | -6x | +
- y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5+ #' |
|
| 76 |
- )+ #' @export |
||
| 77 |
-
+ score_occurrences_cols <- function(...) {
|
||
| 78 | -+ | 4x |
- # If header content spans multiple columns, center over these columns+ function(table_row) {
|
| 79 | -6x | +20x |
- if (length(shared_hdr_rows) > 0) {
+ row_counts <- h_row_counts(table_row, ...) |
| 80 | -5x | +20x |
- mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ])+ sum(row_counts) |
| 81 | -5x | +
- for (hr in shared_hdr_rows) {
+ } |
|
| 82 | -6x | +
- hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]]+ } |
|
| 83 | -6x | +
- hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr)+ |
|
| 84 | -6x | +
- for (idx_hl in seq_len(ncol(hdr_lbls))) {
+ #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on |
|
| 85 | -13x | +
- cur_lbl <- tail(hdr_lbls[, idx_hl], 1)+ #' subtables: They sum up all specified column counts in the subtable. This is useful when |
|
| 86 | -13x | +
- which_cols <- if (hr == 1) {
+ #' there is no available content row summing up these counts. |
|
| 87 | -9x | +
- which(mat_strings[hr, ] == hdr_lbls[idx_hl])+ #' |
|
| 88 | -13x | +
- } else { # for >2 col splits, only print labels for each unique combo of nested columns
+ #' @return |
|
| 89 | -4x | +
- which(+ #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable |
|
| 90 | -4x | +
- apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl]))+ #' across all specified columns. |
|
| 91 |
- )+ #' |
||
| 92 |
- }+ #' @examples |
||
| 93 | -13x | +
- line_pos <- c(+ #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl)) |
|
| 94 | -13x | +
- sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding,+ #' |
|
| 95 | -13x | +
- sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding+ #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That |
|
| 96 |
- )+ #' # would require a second pass of `sort_at_path`. |
||
| 97 |
-
+ #' tbl_sorted <- tbl %>% |
||
| 98 | -13x | +
- res <- res ++ #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
|
|
| 99 | -13x | +
- annotate(+ #' |
|
| 100 | -13x | +
- "text",+ #' tbl_sorted |
|
| 101 | -13x | +
- x = mean(line_pos),+ #' |
|
| 102 | -13x | +
- y = nrow(mat_strings) + 1 - hr,+ #' @export |
|
| 103 | -13x | +
- label = cur_lbl,+ score_occurrences_subtable <- function(...) {
|
|
| 104 | -13x | +1x |
- size = fontsize / .pt+ score_table_row <- score_occurrences_cols(...) |
| 105 | -+ | 1x |
- ) ++ function(table_tree) {
|
| 106 | -13x | +2x |
- annotate(+ table_rows <- collect_leaves(table_tree) |
| 107 | -13x | +2x |
- "segment",+ counts <- vapply(table_rows, score_table_row, numeric(1)) |
| 108 | -13x | +2x |
- x = line_pos[1],+ sum(counts) |
| 109 | -13x | +
- xend = line_pos[2],+ } |
|
| 110 | -13x | +
- y = nrow(mat_strings) - hr + 0.5,+ } |
|
| 111 | -13x | +
- yend = nrow(mat_strings) - hr + 0.5+ |
|
| 112 |
- )+ #' @describeIn score_occurrences Produces a score function for sorting table by summing the first content row in |
||
| 113 |
- }+ #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()]. |
||
| 114 |
- }+ #' |
||
| 115 |
- }+ #' @return |
||
| 116 |
-
+ #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in |
||
| 117 |
- # Add table columns+ #' specified columns. |
||
| 118 | -6x | +
- for (i in seq_len(ncol(tbl_df))) {
+ #' |
|
| 119 | -40x | +
- res <- res + annotate(+ #' @export |
|
| 120 | -40x | +
- "text",+ score_occurrences_cont_cols <- function(...) {
|
|
| 121 | -40x | +1x |
- x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding,+ score_table_row <- score_occurrences_cols(...) |
| 122 | -40x | +1x |
- y = rev(seq_len(nrow(tbl_df))),+ function(table_tree) {
|
| 123 | -40x | +2x |
- label = tbl_df[, i],+ if (inherits(table_tree, "ContentRow")) {
|
| 124 | -40x | +! |
- hjust = mat_aligns[, i],+ return(NA) |
| 125 | -40x | +
- size = fontsize / .pt+ } |
|
| 126 | -+ | 2x |
- )+ content_row <- h_content_first_row(table_tree) |
| 127 | -+ | 2x |
- }+ score_table_row(content_row) |
| 128 |
-
+ } |
||
| 129 | -6x | +
- res+ } |
| 130 | +1 |
- }+ #' Helper function to create a new SMQ variable in ADAE by stacking SMQ and/or CQ records. |
||
| 131 | +2 |
-
+ #' |
||
| 132 | +3 |
- #' Convert `data.frame` object to `ggplot` object+ #' @description `r lifecycle::badge("stable")`
|
||
| 133 | +4 |
#' |
||
| 134 | +5 |
- #' @description `r lifecycle::badge("experimental")`
+ #' Helper function to create a new SMQ variable in ADAE that consists of all adverse events belonging to |
||
| 135 | +6 |
- #'+ #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events |
||
| 136 | +7 |
- #' Given a `data.frame` object, performs basic conversion to a [ggplot2::ggplot()] object built using+ #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing |
||
| 137 | +8 |
- #' functions from the `ggplot2` package.+ #' done with [df_explicit_na()] to have the desired output. |
||
| 138 | +9 |
#' |
||
| 139 | +10 |
- #' @param df (`data.frame`)\cr a data frame.+ #' @inheritParams argument_convention |
||
| 140 | +11 |
- #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in+ #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries. |
||
| 141 | +12 |
- #' `colwidths` corresponds to the column of `df` in the same position. If `NULL`, column widths+ #' @param smq_varlabel (`string`)\cr a label for the new variable created. |
||
| 142 | +13 |
- #' are calculated according to maximum number of characters per column.+ #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created. |
||
| 143 | +14 |
- #' @param font_size (`numeric(1)`)\cr font size.+ #' @param aag_summary (`data.frame`)\cr containing the SMQ baskets and the levels of interest for the final SMQ |
||
| 144 | +15 |
- #' @param col_labels (`flag`)\cr whether the column names (labels) of `df` should be used as the first row+ #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset. |
||
| 145 | +16 |
- #' of the output table.+ #' The two columns of this dataset should be named `basket` and `basket_name`. |
||
| 146 | +17 |
- #' @param col_lab_fontface (`string`)\cr font face to apply to the first row (of column labels+ #' |
||
| 147 | +18 |
- #' if `col_labels = TRUE`). Defaults to `"bold"`.+ #' @return A `data.frame` with variables in `keys` taken from `df` and new variable SMQ containing |
||
| 148 | +19 |
- #' @param hline (`flag`)\cr whether a horizontal line should be printed below the first row of the table.+ #' records belonging to the baskets selected via the `baskets` argument. |
||
| 149 | +20 |
- #' @param bg_fill (`string`)\cr table background fill color.+ #' |
||
| 150 | +21 |
- #'+ #' @examples |
||
| 151 | +22 |
- #' @return A `ggplot` object.+ #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na() |
||
| 152 | +23 |
- #'+ #' h_stack_by_baskets(df = adae) |
||
| 153 | +24 |
- #' @examples+ #' |
||
| 154 | +25 |
- #' \dontrun{
+ #' aag <- data.frame( |
||
| 155 | +26 |
- #' df2gg(head(iris, 5))+ #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
|
||
| 156 | +27 |
- #'+ #' REFNAME = c( |
||
| 157 | +28 |
- #' df2gg(head(iris, 5), font_size = 15, colwidths = c(1, 1, 1, 1, 1))+ #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi", |
||
| 158 | +29 |
- #' }+ #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi" |
||
| 159 | +30 |
- #' @keywords internal+ #' ), |
||
| 160 | +31 |
- df2gg <- function(df,+ #' SCOPE = c("", "", "BROAD", "BROAD"),
|
||
| 161 | +32 |
- colwidths = NULL,+ #' stringsAsFactors = FALSE |
||
| 162 | +33 |
- font_size = 10,+ #' ) |
||
| 163 | +34 |
- col_labels = TRUE,+ #' |
||
| 164 | +35 |
- col_lab_fontface = "bold",+ #' basket_name <- character(nrow(aag)) |
||
| 165 | +36 |
- hline = TRUE,+ #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
|
||
| 166 | +37 |
- bg_fill = NULL) {
+ #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
|
||
| 167 | +38 |
- # convert to text+ #' basket_name[cq_pos] <- aag$REFNAME[cq_pos] |
||
| 168 | -19x | +|||
| 39 | +
- df <- as.data.frame(apply(df, 1:2, function(x) if (is.na(x)) "NA" else as.character(x)))+ #' basket_name[smq_pos] <- paste0( |
|||
| 169 | +40 |
-
+ #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
|
||
| 170 | -19x | +|||
| 41 | +
- if (col_labels) {
+ #' ) |
|||
| 171 | -10x | +|||
| 42 | +
- df <- as.matrix(df)+ #' |
|||
| 172 | -10x | +|||
| 43 | +
- df <- rbind(colnames(df), df)+ #' aag_summary <- data.frame( |
|||
| 173 | +44 |
- }+ #' basket = aag$NAMVAR, |
||
| 174 | +45 |
-
+ #' basket_name = basket_name, |
||
| 175 | +46 |
- # Get column widths+ #' stringsAsFactors = TRUE |
||
| 176 | -19x | +|||
| 47 | +
- if (is.null(colwidths)) {
+ #' ) |
|||
| 177 | -1x | -
- colwidths <- apply(df, 2, function(x) max(nchar(x), na.rm = TRUE))+ | ||
| 48 | ++ |
+ #' |
||
| 178 | +49 |
- }+ #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)+ |
+ ||
| 50 | ++ |
+ #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ |
+ ||
| 51 | ++ |
+ #'+ |
+ ||
| 52 | ++ |
+ #' h_stack_by_baskets(+ |
+ ||
| 53 | ++ |
+ #' df = adae,+ |
+ ||
| 54 | ++ |
+ #' aag_summary = NULL,+ |
+ ||
| 55 | ++ |
+ #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
+ |
+ ||
| 56 | ++ |
+ #' baskets = "SMQ01NAM"+ |
+ ||
| 57 | ++ |
+ #' )+ |
+ ||
| 58 | ++ |
+ #'+ |
+ ||
| 59 | ++ |
+ #' @export+ |
+ ||
| 60 | ++ |
+ h_stack_by_baskets <- function(df,+ |
+ ||
| 61 | ++ |
+ baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
+ |
+ ||
| 62 | ++ |
+ smq_varlabel = "Standardized MedDRA Query",+ |
+ ||
| 63 | ++ |
+ keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
+ |
+ ||
| 64 | ++ |
+ aag_summary = NULL,+ |
+ ||
| 65 | ++ |
+ na_str = "<Missing>") {
|
||
| 179 | -19x | +66 | +5x |
- tot_width <- sum(colwidths)+ smq_nam <- baskets[startsWith(baskets, "SMQ")] |
| 180 | +67 | ++ |
+ # SC corresponding to NAM+ |
+ |
| 68 | +5x | +
+ smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)+ |
+ ||
| 69 | +5x | +
+ smq <- stats::setNames(smq_sc, smq_nam)+ |
+ ||
| 70 | ||||
| 181 | -19x | +71 | +5x |
- res <- ggplot(data = df) ++ checkmate::assert_character(baskets) |
| 182 | -19x | +72 | +5x |
- theme_void() ++ checkmate::assert_string(smq_varlabel) |
| 183 | -19x | +73 | +5x |
- scale_x_continuous(limits = c(0, tot_width)) ++ checkmate::assert_data_frame(df) |
| 184 | -19x | +74 | +5x |
- scale_y_continuous(limits = c(1, nrow(df)))+ checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))+ |
+
| 75 | +4x | +
+ checkmate::assert_true(all(endsWith(baskets, "NAM")))+ |
+ ||
| 76 | +3x | +
+ checkmate::assert_subset(baskets, names(df))+ |
+ ||
| 77 | +3x | +
+ checkmate::assert_subset(keys, names(df))+ |
+ ||
| 78 | +3x | +
+ checkmate::assert_subset(smq_sc, names(df))+ |
+ ||
| 79 | +3x | +
+ checkmate::assert_string(na_str) |
||
| 185 | +80 | |||
| 186 | -9x | +81 | +3x |
- if (!is.null(bg_fill)) res <- res + theme(plot.background = element_rect(fill = bg_fill))+ if (!is.null(aag_summary)) {
+ |
+
| 82 | +1x | +
+ assert_df_with_variables(+ |
+ ||
| 83 | +1x | +
+ df = aag_summary,+ |
+ ||
| 84 | +1x | +
+ variables = list(val = c("basket", "basket_name"))
|
||
| 187 | +85 | ++ |
+ )+ |
+ |
| 86 | ++ |
+ # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.+ |
+ ||
| 87 | ++ |
+ # Honestly, I think those should completely match. Target baskets should be the same.+ |
+ ||
| 88 | +1x | +
+ if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
+ |
+ ||
| 89 | +! | +
+ warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
+ |
+ ||
| 90 | ++ |
+ }+ |
+ ||
| 91 | ++ |
+ }+ |
+ ||
| 92 | ||||
| 188 | -19x | +93 | +3x |
- if (hline) {
+ var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)+ |
+
| 94 | ++ | + + | +||
| 95 | ++ |
+ # convert `na_str` records from baskets to NA for the later loop and from wide to long steps |
||
| 189 | -10x | +96 | +3x |
- res <- res ++ df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA+ |
+
| 97 | ++ | + | ||
| 190 | -10x | +98 | +3x |
- annotate(+ if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
|
| 191 | -10x | +99 | +1x |
- "segment",+ df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty data frame keeping all factor levels+ |
+
| 100 | ++ |
+ } else {
+ |
+ ||
| 101 | ++ |
+ # Concatenate SMQxxxNAM with corresponding SMQxxxSC |
||
| 192 | -10x | +102 | +2x |
- x = 0 + 0.2 * colwidths[2], xend = tot_width - 0.1 * tail(colwidths, 1),+ df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]+ |
+
| 103 | ++ | + | ||
| 193 | -10x | +104 | +2x |
- y = nrow(df) - 0.5, yend = nrow(df) - 0.5+ for (nam in names(smq)) {
+ |
+
| 105 | +4x | +
+ sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ |
+ ||
| 106 | +4x | +
+ nam_notna <- !is.na(df[[nam]])+ |
+ ||
| 107 | +4x | +
+ new_colname <- paste(nam, sc, sep = "_")+ |
+ ||
| 108 | +4x | +
+ df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
|
||
| 194 | +109 |
- )+ } |
||
| 195 | +110 |
- }+ + |
+ ||
| 111 | +2x | +
+ df_cnct$unique_id <- seq(1, nrow(df_cnct))+ |
+ ||
| 112 | +2x | +
+ var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))] |
||
| 196 | +113 | ++ |
+ # have to convert df_cnct from tibble to data frame+ |
+ |
| 114 | ++ |
+ # as it throws a warning otherwise about rownames.+ |
+ ||
| 115 | ++ |
+ # tibble do not support rownames and reshape creates rownames+ |
+ ||
| 116 | ||||
| 197 | -19x | +117 | +2x |
- for (i in seq_len(ncol(df))) {
+ df_long <- stats::reshape( |
| 198 | -86x | +118 | +2x |
- line_pos <- c(+ data = as.data.frame(df_cnct), |
| 199 | -86x | +119 | +2x |
- if (i == 1) 0 else sum(colwidths[1:(i - 1)]),+ varying = var_cols, |
| 200 | -86x | +120 | +2x |
- sum(colwidths[1:i])+ v.names = "SMQ",+ |
+
| 121 | +2x | +
+ idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ |
+ ||
| 122 | +2x | +
+ direction = "long",+ |
+ ||
| 123 | +2x | +
+ new.row.names = seq(prod(length(var_cols), nrow(df_cnct))) |
||
| 201 | +124 |
) |
||
| 125 | ++ | + + | +||
| 202 | -86x | +126 | +2x |
- res <- res ++ df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
|
| 203 | -86x | +127 | +2x |
- annotate(+ df_long$SMQ <- as.factor(df_long$SMQ)+ |
+
| 128 | ++ |
+ }+ |
+ ||
| 129 | ++ | + | ||
| 204 | -86x | +130 | +3x |
- "text",+ smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str)+ |
+
| 131 | ++ | + | ||
| 205 | -86x | +132 | +3x |
- x = mean(line_pos),+ if (!is.null(aag_summary)) {
+ |
+
| 133 | ++ |
+ # A warning in case there is no match between df and aag_summary records |
||
| 206 | -86x | +134 | +1x |
- y = rev(seq_len(nrow(df))),+ if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
|
| 207 | -86x | +135 | +1x |
- label = df[, i],+ warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
+ |
+
| 136 | ++ |
+ } |
||
| 208 | -86x | +137 | +1x |
- size = font_size / .pt,+ df_long[["SMQ"]] <- factor( |
| 209 | -86x | +138 | +1x |
- fontface = if (col_labels) {
+ df_long[["SMQ"]], |
| 210 | -32x | +139 | +1x |
- c(col_lab_fontface, rep("plain", nrow(df) - 1))
+ levels = sort( |
| 211 | -+ | |||
| 140 | +1x |
- } else {
+ c( |
||
| 212 | -54x | +141 | +1x |
- rep("plain", nrow(df))
+ smq_levels,+ |
+
| 142 | +1x | +
+ setdiff(unique(aag_summary$basket_name), smq_levels) |
||
| 213 | +143 |
- }+ ) |
||
| 214 | +144 |
) |
||
| 215 | +145 |
- }+ ) |
||
| 216 | +146 | ++ |
+ } else {
+ |
+ |
| 147 | +2x | +
+ all_na_basket_flag <- vapply(df[, baskets], function(x) {
+ |
+ ||
| 148 | +6x | +
+ all(is.na(x))+ |
+ ||
| 149 | +2x | +
+ }, FUN.VALUE = logical(1))+ |
+ ||
| 150 | +2x | +
+ all_na_basket <- baskets[all_na_basket_flag]+ |
+ ||
| 151 | ||||
| 217 | -19x | +152 | +2x |
- res+ df_long[["SMQ"]] <- factor(+ |
+
| 153 | +2x | +
+ df_long[["SMQ"]],+ |
+ ||
| 154 | +2x | +
+ levels = sort(c(smq_levels, all_na_basket)) |
||
| 218 | +155 | ++ |
+ )+ |
+ |
| 156 | ++ |
+ }+ |
+ ||
| 157 | +3x | +
+ formatters::var_labels(df_long) <- var_labels+ |
+ ||
| 158 | +3x | +
+ tibble::tibble(df_long)+ |
+ ||
| 159 |
}@@ -171782,14 +171038,14 @@ tern coverage - 95.65% |
| 1 |
- #' Create a STEP graph+ #' Split function to configure risk difference column |
|||
| 5 |
- #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR+ #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference |
|||
| 6 |
- #' along the continuous biomarker value subgroups.+ #' column to be added to an `rtables` object. To add a risk difference column to a table, this function |
|||
| 7 |
- #'+ #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument |
|||
| 8 |
- #' @param df (`tibble`)\cr result of [tidy.step()].+ #' `riskdiff` to `TRUE` in all following analyze function calls. |
|||
| 9 |
- #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual+ #' |
|||
| 10 |
- #' biomarker values.+ #' @param arm_x (`string`)\cr name of reference arm to use in risk difference calculations. |
|||
| 11 |
- #' @param est (named `list`)\cr `col` and `lty` settings for estimate line.+ #' @param arm_y (`character`)\cr names of one or more arms to compare to reference arm in risk difference |
|||
| 12 |
- #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval+ #' calculations. A new column will be added for each value of `arm_y`. |
|||
| 13 |
- #' ribbon area, or `NULL` to not plot a CI ribbon.+ #' @param col_label (`character`)\cr labels to use when rendering the risk difference column within the table. |
|||
| 14 |
- #' @param col (`character`)\cr color(s).+ #' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are |
|||
| 15 |
- #'+ #' being compared (reference arm vs. comparison arm). |
|||
| 16 |
- #' @return A `ggplot` STEP graph.+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
|||
| 18 |
- #' @seealso Custom tidy method [tidy.step()].+ #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()] |
|||
| 19 |
- #'+ #' when creating a table layout. |
|||
| 20 |
- #' @examples+ #' |
|||
| 21 |
- #' library(survival)+ #' @seealso [stat_propdiff_ci()] for details on risk difference calculation. |
|||
| 22 |
- #' lung$sex <- factor(lung$sex)+ #' |
|||
| 23 |
- #'+ #' @examples |
|||
| 24 |
- #' # Survival example.+ #' adae <- tern_ex_adae |
|||
| 25 |
- #' vars <- list(+ #' adae$AESEV <- factor(adae$AESEV) |
|||
| 26 |
- #' time = "time",+ #' |
|||
| 27 |
- #' event = "status",+ #' lyt <- basic_table() %>% |
|||
| 28 |
- #' arm = "sex",+ #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
|
|||
| 29 |
- #' biomarker = "age"+ #' count_occurrences_by_grade( |
|||
| 30 |
- #' )+ #' var = "AESEV", |
|||
| 31 |
- #'+ #' riskdiff = TRUE |
|||
| 32 |
- #' step_matrix <- fit_survival_step(+ #' ) |
|||
| 33 |
- #' variables = vars,+ #' |
|||
| 34 |
- #' data = lung,+ #' tbl <- build_table(lyt, df = adae) |
|||
| 35 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' tbl |
|||
| 36 |
- #' )+ #' |
|||
| 37 |
- #' step_data <- broom::tidy(step_matrix)+ #' @export |
|||
| 38 |
- #'+ add_riskdiff <- function(arm_x, |
|||
| 39 |
- #' # Default plot.+ arm_y, |
|||
| 40 |
- #' g_step(step_data)+ col_label = paste0( |
|||
| 41 |
- #'+ "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
|
|||
| 42 |
- #' # Add the reference 1 horizontal line.+ ), |
|||
| 43 |
- #' library(ggplot2)+ pct = TRUE) {
|
|||
| 44 | -+ | 19x |
- #' g_step(step_data) ++ checkmate::assert_character(arm_x, len = 1) |
|
| 45 | -+ | 19x |
- #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)+ checkmate::assert_character(arm_y, min.len = 1) |
|
| 46 | -+ | 19x |
- #'+ checkmate::assert_character(col_label, len = length(arm_y)) |
|
| 47 |
- #' # Use actual values instead of percentiles, different color for estimate and no CI,+ |
|||
| 48 | -+ | 19x |
- #' # use log scale for y axis.+ combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs) |
|
| 49 | -+ | 19x |
- #' g_step(+ for (i in seq_len(length(arm_y))) {
|
|
| 50 | -+ | 20x |
- #' step_data,+ combodf <- rbind( |
|
| 51 | -+ | 20x |
- #' use_percentile = FALSE,+ combodf, |
|
| 52 | -+ | 20x |
- #' est = list(col = "blue", lty = 1),+ tibble::tribble( |
|
| 53 | -+ | 20x |
- #' ci_ribbon = NULL+ ~valname, ~label, ~levelcombo, ~exargs, |
|
| 54 | -+ | 20x |
- #' ) + scale_y_log10()+ paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
|
|
| 55 |
- #'+ ) |
|||
| 56 |
- #' # Adding another curve based on additional column.+ ) |
|||
| 57 |
- #' step_data$extra <- exp(step_data$`Percentile Center`)+ } |
|||
| 58 | -+ | 19x |
- #' g_step(step_data) ++ if (pct) combodf$valname <- paste0(combodf$valname, "_pct") |
|
| 59 | -+ | 19x |
- #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")+ add_combo_levels(combodf) |
|
| 60 |
- #'+ } |
|||
| 61 |
- #' # Response example.+ |
|||
| 62 |
- #' vars <- list(+ #' Analysis function to calculate risk difference column values |
|||
| 63 |
- #' response = "status",+ #' |
|||
| 64 |
- #' arm = "sex",+ #' In the risk difference column, this function uses the statistics function associated with `afun` to |
|||
| 65 |
- #' biomarker = "age"+ #' 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 |
- #' step_matrix <- fit_rsp_step(+ #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations. |
|||
| 69 |
- #' variables = vars,+ #' |
|||
| 70 |
- #' data = lung,+ #' @inheritParams argument_convention |
|||
| 71 |
- #' control = c(+ #' @param afun (named `list`)\cr a named list containing one name-value pair where the name corresponds to |
|||
| 72 |
- #' control_logistic(response_definition = "I(response == 2)"),+ #' the name of the statistics function that should be used in calculations and the value is the corresponding |
|||
| 73 |
- #' control_step()+ #' 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 |
- #' step_data <- broom::tidy(step_matrix)+ #' |
|||
| 77 |
- #' g_step(step_data)+ #' @return A list of formatted [rtables::CellValue()]. |
|||
| 79 |
- #' @export+ #' @seealso |
|||
| 80 |
- g_step <- function(df,+ #' * [stat_propdiff_ci()] for details on risk difference calculation. |
|||
| 81 |
- use_percentile = "Percentile Center" %in% names(df),+ #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with |
|||
| 82 |
- est = list(col = "blue", lty = 1),+ #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column |
|||
| 83 |
- ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
+ #' to a table layout. |
|||
| 84 |
- col = getOption("ggplot2.discrete.colour")) {
+ #' |
|||
| 85 | -2x | +
- checkmate::assert_tibble(df)+ #' @keywords internal |
||
| 86 | -2x | +
- checkmate::assert_flag(use_percentile)+ afun_riskdiff <- function(df, |
||
| 87 | -2x | +
- checkmate::assert_character(col, null.ok = TRUE)+ labelstr = "", |
||
| 88 | -2x | +
- checkmate::assert_list(est, names = "named")+ .var, |
||
| 89 | -2x | +
- checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE)+ .N_col, # nolint |
||
| 90 |
-
+ .N_row, # nolint |
|||
| 91 | -2x | +
- x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center")+ .df_row, |
||
| 92 | -2x | +
- df$x <- df[[x_var]]+ .spl_context, |
||
| 93 | -2x | +
- attrs <- attributes(df)+ .all_col_counts, |
||
| 94 | -2x | +
- df$y <- df[[attrs$estimate]]+ .stats, |
||
| 95 |
-
+ .formats = NULL, |
|||
| 96 |
- # Set legend names. To be modified also at call level+ .labels = NULL, |
|||
| 97 | -2x | +
- legend_names <- c("Estimate", "CI 95%")
+ .indent_mods = NULL, |
||
| 98 |
-
+ na_str = default_na_str(), |
|||
| 99 | -2x | +
- p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]]))+ afun, |
||
| 100 |
-
+ s_args = list()) {
|
|||
| 101 | -2x | +146x |
- if (!is.null(col)) {
+ if (!any(grepl("riskdiff", names(.spl_context)))) {
|
|
| 102 | -2x | +! |
- p <- p ++ stop( |
|
| 103 | -2x | +! |
- ggplot2::scale_color_manual(values = col)+ "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." |
|
| 105 |
-
+ ) |
|||
| 106 | -2x | +
- if (!is.null(ci_ribbon)) {
+ } |
||
| 107 | -1x | +146x |
- if (is.null(ci_ribbon$fill)) {
+ checkmate::assert_list(afun, len = 1, types = "function") |
|
| 108 | -! | +146x |
- ci_ribbon$fill <- "lightblue"+ checkmate::assert_named(afun) |
|
| 109 | -+ | 146x |
- }+ afun_args <- list( |
|
| 110 | -1x | +146x |
- p <- p + ggplot2::geom_ribbon(+ .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr, |
|
| 111 | -1x | +146x |
- ggplot2::aes(+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
|
| 112 | -1x | +
- ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]],+ ) |
||
| 113 | -1x | +146x |
- fill = legend_names[2]+ 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
|
|
| 115 | -1x | +
- alpha = ci_ribbon$alpha+ |
||
| 116 | -+ | 146x |
- ) ++ cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1) |
|
| 117 | -1x | +146x |
- scale_fill_manual(+ if (!grepl("^riskdiff", cur_split)) {
|
|
| 118 | -1x | +
- name = "", values = c("CI 95%" = ci_ribbon$fill)
+ # Apply basic afun (no risk difference) in all other columns |
||
| 119 | -+ | 108x |
- )+ do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args)) |
|
| 120 |
- }+ } else {
|
|||
| 121 | -2x | +38x |
- suppressMessages(p <- p ++ arm_x <- strsplit(cur_split, "_")[[1]][2] |
|
| 122 | -2x | +38x |
- ggplot2::geom_line(+ arm_y <- strsplit(cur_split, "_")[[1]][3] |
|
| 123 | -2x | +38x |
- ggplot2::aes(y = .data[["y"]], color = legend_names[1]),+ if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
|
|
| 124 | -2x | +8x |
- linetype = est$lty+ arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
|
|
| 125 | -+ | 8x |
- ) ++ arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
|
|
| 126 | -2x | +
- scale_colour_manual(+ } else {
|
||
| 127 | -2x | +30x |
- name = "", values = c("Estimate" = "blue")
+ arm_spl_x <- arm_x |
|
| 128 | -+ | 30x |
- ))+ arm_spl_y <- arm_y |
|
| 129 |
-
+ } |
|||
| 130 | -2x | +38x |
- p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate)+ N_col_x <- .all_col_counts[[arm_spl_x]] # nolint |
|
| 131 | -2x | +38x |
- if (use_percentile) {
+ N_col_y <- .all_col_counts[[arm_spl_y]] # nolint |
|
| 132 | -1x | +38x |
- p <- p + ggplot2::scale_x_continuous(labels = scales::percent)+ cur_var <- tail(.spl_context$cur_col_split[[1]], 1) |
|
| 133 |
- }+ |
|||
| 134 | -2x | +
- p+ # Apply statistics function to arm X and arm Y data |
||
| 135 | -+ | 38x |
- }+ s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))]) |
|
| 136 | -+ | 38x |
-
+ s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args)) |
|
| 137 | -+ | 38x |
- #' Custom tidy method for STEP results+ s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args)) |
|
| 138 |
- #'+ |
|||
| 139 |
- #' @description `r lifecycle::badge("stable")`
+ # Get statistic name and row names |
|||
| 140 | -+ | 38x |
- #'+ stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
|
|
| 141 | -+ | 38x |
- #' Tidy the STEP results into a `tibble` format ready for plotting.+ if ("flag_variables" %in% names(s_args)) {
|
|
| 142 | -+ | 2x |
- #'+ var_nms <- s_args$flag_variables |
|
| 143 | -+ | 36x |
- #' @param x (`matrix`)\cr results from [fit_survival_step()].+ } else if (!is.null(names(s_x[[stat]]))) {
|
|
| 144 | -+ | 24x |
- #' @param ... not used.+ var_nms <- names(s_x[[stat]]) |
|
| 145 |
- #'+ } else {
|
|||
| 146 | -+ | 12x |
- #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,+ var_nms <- "" |
|
| 147 | -+ | 12x |
- #' respectively. Additional attributes carry metadata also used for plotting.+ s_x[[stat]] <- list(s_x[[stat]]) |
|
| 148 | -+ | 12x |
- #'+ s_y[[stat]] <- list(s_y[[stat]]) |
|
| 149 |
- #' @seealso [g_step()] which consumes the result from this function.+ } |
|||
| 150 |
- #'+ |
|||
| 151 |
- #' @method tidy step+ # Calculate risk difference for each row, repeated if multiple statistics in table |
|||
| 152 | -+ | 38x |
- #'+ pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct" |
|
| 153 | -+ | 38x |
- #' @examples+ rd_ci <- rep(stat_propdiff_ci( |
|
| 154 | -+ | 38x |
- #' library(survival)+ lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1), |
|
| 155 | -+ | 38x |
- #' lung$sex <- factor(lung$sex)+ N_col_x, N_col_y, |
|
| 156 | -+ | 38x |
- #' vars <- list(+ list_names = var_nms, |
|
| 157 | -+ | 38x |
- #' time = "time",+ pct = pct |
|
| 158 | -+ | 38x |
- #' event = "status",+ ), max(1, length(.stats))) |
|
| 159 |
- #' arm = "sex",+ |
|||
| 160 | -+ | 38x |
- #' biomarker = "age"+ in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods) |
|
| 161 |
- #' )+ } |
|||
| 162 |
- #' step_matrix <- fit_survival_step(+ } |
|||
| 163 |
- #' variables = vars,+ |
|||
| 164 |
- #' data = lung,+ #' Control function for risk difference column |
|||
| 165 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' |
|||
| 166 |
- #' )+ #' @description `r lifecycle::badge("stable")`
|
|||
| 167 |
- #' broom::tidy(step_matrix)+ #' |
|||
| 168 |
- #'+ #' Sets a list of parameters to use when generating a risk (proportion) difference column. Used as input to the |
|||
| 169 |
- #' @export+ #' `riskdiff` parameter of [tabulate_rsp_subgroups()] and [tabulate_survival_subgroups()]. |
|||
| 170 |
- tidy.step <- function(x, ...) { # nolint
+ #' |
|||
| 171 | -7x | +
- checkmate::assert_class(x, "step")+ #' @inheritParams add_riskdiff |
||
| 172 | -7x | +
- dat <- as.data.frame(x)+ #' @param format (`string` or `function`)\cr the format label (string) or formatting function to apply to the risk |
||
| 173 | -7x | +
- nams <- names(dat)+ #' difference statistic. See the `3d` string options in [formatters::list_valid_format_labels()] for possible format |
||
| 174 | -7x | +
- is_surv <- "loghr" %in% names(dat)+ #' strings. Defaults to `"xx.x (xx.x - xx.x)"`. |
||
| 175 | -7x | +
- est_var <- ifelse(is_surv, "loghr", "logor")+ #' |
||
| 176 | -7x | +
- new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio")+ #' @return A `list` of items with names corresponding to the arguments. |
||
| 177 | -7x | +
- new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
+ #' |
||
| 178 | -7x | +
- names(dat)[match(est_var, nams)] <- new_est_var+ #' @seealso [add_riskdiff()], [tabulate_rsp_subgroups()], and [tabulate_survival_subgroups()]. |
||
| 179 | -7x | +
- dat[, new_y_vars] <- exp(dat[, new_y_vars])+ #' |
||
| 180 | -7x | +
- any_is_na <- any(is.na(dat[, new_y_vars]))+ #' @examples |
||
| 181 | -7x | +
- any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE)+ #' control_riskdiff() |
||
| 182 | -7x | +
- if (any_is_na) {
+ #' control_riskdiff(arm_x = "ARM A", arm_y = "ARM B") |
||
| 183 | -2x | +
- warning(paste(+ #' |
||
| 184 | -2x | +
- "Missing values in the point estimate or CI columns,",+ #' @export |
||
| 185 | -2x | +
- "this will lead to holes in the `g_step()` plot"+ control_riskdiff <- function(arm_x = NULL, |
||
| 186 |
- ))+ arm_y = NULL, |
|||
| 187 |
- }+ format = "xx.x (xx.x - xx.x)", |
|||
| 188 | -7x | +
- if (any_is_very_large) {
+ col_label = "Risk Difference (%) (95% CI)", |
||
| 189 | -2x | +
- warning(paste(+ pct = TRUE) {
|
||
| 190 | 2x |
- "Very large absolute values in the point estimate or CI columns,",+ checkmate::assert_character(arm_x, len = 1, null.ok = TRUE) |
||
| 191 | 2x |
- "consider adding `scale_y_log10()` to the `g_step()` result for plotting"+ checkmate::assert_character(arm_y, min.len = 1, null.ok = TRUE) |
||
| 192 | -+ | 2x |
- ))+ checkmate::assert_character(format, len = 1) |
|
| 193 | -+ | 2x |
- }+ checkmate::assert_character(col_label) |
|
| 194 | -7x | -
- if (any_is_na || any_is_very_large) {
- |
- ||
| 195 | -4x | +2x |
- warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
+ checkmate::assert_flag(pct) |
|
| 196 | +195 |
- }- |
- ||
| 197 | -7x | -
- structure(- |
- ||
| 198 | -7x | -
- tibble::as_tibble(dat),- |
- ||
| 199 | -7x | -
- estimate = new_est_var,- |
- ||
| 200 | -7x | -
- biomarker = attr(x, "variables")$biomarker,+ |
||
| 201 | -7x | -
- ci = f_conf_level(attr(x, "control")$conf_level)- |
- ||
| 202 | -+ | 196 | +2x |
- )+ list(arm_x = arm_x, arm_y = arm_y, format = format, col_label = col_label, pct = pct) |
| 203 | +197 |
}@@ -174804,14 +174018,14 @@ tern coverage - 95.65% |
| 1 |
- #' Count number of patients and sum exposure across all patients in columns+ #' Count the number of patients with a particular event |
||
| 5 |
- #' The analyze function [analyze_patients_exposure_in_cols()] creates a layout element to count total numbers of+ #' The analyze function [count_patients_with_event()] creates a layout element to calculate patient counts for a |
||
| 6 |
- #' patients and sum an analysis value (i.e. exposure) across all patients in columns.+ #' user-specified set of events. |
||
| 8 |
- #' The primary analysis variable `ex_var` is the exposure variable used to calculate the `sum_exposure` statistic. The+ #' This function analyzes primary analysis variable `vars` which indicates unique subject identifiers. Events |
||
| 9 |
- #' `id` variable is used to uniquely identify patients in the data such that only unique patients are counted in the+ #' are defined by the user as a named vector via the `filters` argument, where each name corresponds to a |
||
| 10 |
- #' `n_patients` statistic, and the `var` variable is used to create a row split if needed. The percentage returned as+ #' variable and each value is the value(s) that that variable takes for the event. |
||
| 11 |
- #' part of the `n_patients` statistic is the proportion of all records that correspond to a unique patient.+ #' |
||
| 12 |
- #'+ #' If there are multiple records with the same event recorded for a patient, only one occurrence is counted. |
||
| 13 |
- #' The summarize function [summarize_patients_exposure_in_cols()] performs the same function as+ #' |
||
| 14 |
- #' [analyze_patients_exposure_in_cols()] except it creates content rows, not data rows, to summarize the current table+ #' @inheritParams argument_convention |
||
| 15 |
- #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have+ #' @param filters (`character`)\cr a character vector specifying the column names and flag variables |
||
| 16 |
- #' occurred.+ #' to be used for counting the number of unique identifiers satisfying such conditions. |
||
| 17 |
- #'+ #' Multiple column names and flags are accepted in this format |
||
| 18 |
- #' If a column split has not yet been performed in the table, `col_split` must be set to `TRUE` for the first call of+ #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
|
||
| 19 |
- #' [analyze_patients_exposure_in_cols()] or [summarize_patients_exposure_in_cols()].+ #' Note that only equality is being accepted as condition. |
||
| 20 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 21 |
- #' @inheritParams argument_convention+ #' |
||
| 22 |
- #' @param ex_var (`string`)\cr name of the variable in `df` containing exposure values.+ #' Options are: ``r shQuote(get_stats("count_patients_with_event"))``
|
||
| 23 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty, this will be used as label.+ #' |
||
| 24 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @seealso [count_patients_with_flags()] |
||
| 26 |
- #' Options are: ``r shQuote(get_stats("analyze_patients_exposure_in_cols"))``
+ #' @name count_patients_with_event |
||
| 27 |
- #'+ #' @order 1 |
||
| 28 |
- #' @name summarize_patients_exposure_in_cols+ NULL |
||
| 29 |
- #' @order 1+ |
||
| 30 |
- NULL+ #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which |
||
| 31 |
-
+ #' the defined event has occurred. |
||
| 32 |
- #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers+ #' |
||
| 33 |
- #' of patients and the sum of exposure across all patients.+ #' @inheritParams analyze_variables |
||
| 34 |
- #'+ #' @param .var (`string`)\cr name of the column that contains the unique identifier. |
||
| 35 |
- #' @return+ #' |
||
| 36 |
- #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics:+ #' @return |
||
| 37 |
- #' * `n_patients`: Number of unique patients in `df`.+ #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event. |
||
| 38 |
- #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`.+ #' |
||
| 39 |
- #'+ #' @examples |
||
| 40 |
- #' @keywords internal+ #' s_count_patients_with_event( |
||
| 41 |
- s_count_patients_sum_exposure <- function(df,+ #' tern_ex_adae, |
||
| 42 |
- ex_var = "AVAL",+ #' .var = "SUBJID", |
||
| 43 |
- id = "USUBJID",+ #' filters = c("TRTEMFL" = "Y")
|
||
| 44 |
- labelstr = "",+ #' ) |
||
| 45 |
- .stats = c("n_patients", "sum_exposure"),
+ #' |
||
| 46 |
- .N_col, # nolint+ #' s_count_patients_with_event( |
||
| 47 |
- custom_label = NULL) {
+ #' tern_ex_adae, |
||
| 48 | -56x | +
- assert_df_with_variables(df, list(ex_var = ex_var, id = id))+ #' .var = "SUBJID", |
|
| 49 | -56x | +
- checkmate::assert_string(id)+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
|
|
| 50 | -56x | +
- checkmate::assert_string(labelstr)+ #' ) |
|
| 51 | -56x | +
- checkmate::assert_string(custom_label, null.ok = TRUE)+ #' |
|
| 52 | -56x | +
- checkmate::assert_numeric(df[[ex_var]])+ #' s_count_patients_with_event( |
|
| 53 | -56x | +
- checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
+ #' tern_ex_adae, |
|
| 54 |
-
+ #' .var = "SUBJID", |
||
| 55 | -56x | +
- row_label <- if (labelstr != "") {
+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
|
| 56 | -! | +
- labelstr+ #' denom = "N_col", |
|
| 57 | -56x | +
- } else if (!is.null(custom_label)) {
+ #' .N_col = 456 |
|
| 58 | -48x | +
- custom_label+ #' ) |
|
| 59 |
- } else {
+ #' |
||
| 60 | -8x | +
- "Total patients numbers/person time"+ #' @export |
|
| 61 |
- }+ s_count_patients_with_event <- function(df, |
||
| 62 |
-
+ .var, |
||
| 63 | -56x | +
- y <- list()+ filters, |
|
| 64 |
-
+ .N_col, # nolint |
||
| 65 | -56x | +
- if ("n_patients" %in% .stats) {
+ .N_row, # nolint |
|
| 66 | -23x | +
- y$n_patients <-+ denom = c("n", "N_col", "N_row")) {
|
|
| 67 | -23x | +51x |
- formatters::with_label(+ col_names <- names(filters) |
| 68 | -23x | +51x |
- s_num_patients_content(+ filter_values <- filters |
| 69 | -23x | +
- df = df,+ |
|
| 70 | -23x | +51x |
- .N_col = .N_col, # nolint+ checkmate::assert_subset(col_names, colnames(df)) |
| 71 | -23x | +
- .var = id,+ |
|
| 72 | -23x | +51x |
- labelstr = ""+ temp <- Map( |
| 73 | -23x | +51x |
- )$unique,+ function(x, y) which(df[[x]] == y), |
| 74 | -23x | +51x |
- row_label+ col_names, |
| 75 | -+ | 51x |
- )+ filter_values |
| 76 |
- }+ ) |
||
| 77 | -56x | +51x |
- if ("sum_exposure" %in% .stats) {
+ position_satisfy_filters <- Reduce(intersect, temp) |
| 78 | -34x | +51x |
- y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label)+ id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]])) |
| 79 | -+ | 51x |
- }+ result <- s_count_values( |
| 80 | -56x | +51x |
- y+ as.character(unique(df[[.var]])), |
| 81 | -+ | 51x |
- }+ id_satisfy_filters, |
| 82 | -+ | 51x |
-
+ denom = denom, |
| 83 | -+ | 51x |
- #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in+ .N_col = .N_col, |
| 84 | -+ | 51x |
- #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in+ .N_row = .N_row |
| 85 |
- #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`.+ ) |
||
| 86 | -+ | 51x |
- #'+ result |
| 87 |
- #' @return+ } |
||
| 88 |
- #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()].+ |
||
| 89 |
- #'+ #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun` |
||
| 90 |
- #' @examples+ #' in `count_patients_with_event()`. |
||
| 91 |
- #' a_count_patients_sum_exposure(+ #' |
||
| 92 |
- #' df = df,+ #' @return |
||
| 93 |
- #' var = "SEX",+ #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 94 |
- #' .N_col = nrow(df),+ #' |
||
| 95 |
- #' .stats = "n_patients"+ #' @examples |
||
| 96 |
- #' )+ #' a_count_patients_with_event( |
||
| 97 |
- #'+ #' tern_ex_adae, |
||
| 98 |
- #' @export+ #' .var = "SUBJID", |
||
| 99 |
- a_count_patients_sum_exposure <- function(df,+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 100 |
- var = NULL,+ #' .N_col = 100, |
||
| 101 |
- ex_var = "AVAL",+ #' .N_row = 100 |
||
| 102 |
- id = "USUBJID",+ #' ) |
||
| 103 |
- add_total_level = FALSE,+ #' |
||
| 104 |
- custom_label = NULL,+ #' @export |
||
| 105 |
- labelstr = "",+ a_count_patients_with_event <- function(df, |
||
| 106 |
- .N_col, # nolint+ labelstr = "", |
||
| 107 |
- .stats,+ filters, |
||
| 108 |
- .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
+ denom = c("n", "N_col", "N_row"),
|
||
| 109 | -32x | +
- checkmate::assert_flag(add_total_level)+ .N_col, # nolint |
|
| 110 |
-
+ .N_row, # nolint |
||
| 111 | -32x | +
- if (!is.null(var)) {
+ .df_row, |
|
| 112 | -21x | +
- assert_df_with_variables(df, list(var = var))+ .var = NULL, |
|
| 113 | -21x | +
- df[[var]] <- as.factor(df[[var]])+ .stats = NULL, |
|
| 114 |
- }+ .formats = NULL, |
||
| 115 |
-
+ .labels = NULL, |
||
| 116 | -32x | +
- y <- list()+ .indent_mods = NULL, |
|
| 117 | -32x | +
- if (is.null(var)) {
+ na_str = default_na_str()) {
|
|
| 118 | -11x | +19x |
- y[[.stats]] <- list(Total = s_count_patients_sum_exposure(+ x_stats <- s_count_patients_with_event( |
| 119 | -11x | +19x |
- df = df,+ df = df, .var = .var, filters = filters, .N_col = .N_col, .N_row = .N_row, denom = denom |
| 120 | -11x | +
- ex_var = ex_var,+ ) |
|
| 121 | -11x | +
- id = id,+ |
|
| 122 | -11x | +19x |
- labelstr = labelstr,+ if (is.null(unlist(x_stats))) {
|
| 123 | -11x | +! |
- .N_col = .N_col,+ return(NULL) |
| 124 | -11x | +
- .stats = .stats,+ } |
|
| 125 | -11x | +
- custom_label = custom_label+ |
|
| 126 | -11x | +
- )[[.stats]])+ # Fill in with formatting defaults if needed |
|
| 127 | -+ | 19x |
- } else {
+ .stats <- get_stats("count_patients_with_event", stats_in = .stats)
|
| 128 | -21x | +19x |
- for (lvl in levels(df[[var]])) {
+ .formats <- get_formats_from_stats(.stats, .formats) |
| 129 | -42x | +19x |
- y[[.stats]][[lvl]] <- s_count_patients_sum_exposure(+ .labels <- get_labels_from_stats(.stats, .labels) |
| 130 | -42x | +19x |
- df = subset(df, get(var) == lvl),+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
| 131 | -42x | +
- ex_var = ex_var,+ |
|
| 132 | -42x | +1x |
- id = id,+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
| 133 | -42x | +19x |
- labelstr = labelstr,+ x_stats <- x_stats[.stats] |
| 134 | -42x | +
- .N_col = .N_col,+ |
|
| 135 | -42x | +
- .stats = .stats,+ # Auto format handling |
|
| 136 | -42x | +19x |
- custom_label = lvl+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
| 137 | -42x | +
- )[[.stats]]+ |
|
| 138 | -+ | 19x |
- }+ in_rows( |
| 139 | -21x | +19x |
- if (add_total_level) {
+ .list = x_stats, |
| 140 | -2x | +19x |
- y[[.stats]][["Total"]] <- s_count_patients_sum_exposure(+ .formats = .formats, |
| 141 | -2x | +19x |
- df = df,+ .names = names(.labels), |
| 142 | -2x | +19x |
- ex_var = ex_var,+ .labels = unlist(.labels), |
| 143 | -2x | +19x |
- id = id,+ .indent_mods = .indent_mods, |
| 144 | -2x | +19x |
- labelstr = labelstr,+ .format_na_strs = na_str |
| 145 | -2x | +
- .N_col = .N_col,+ ) |
|
| 146 | -2x | +
- .stats = .stats,+ } |
|
| 147 | -2x | +
- custom_label = custom_label+ |
|
| 148 | -2x | +
- )[[.stats]]+ #' @describeIn count_patients_with_event Layout-creating function which can take statistics function |
|
| 149 |
- }+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 150 |
- }+ #' |
||
| 151 |
-
+ #' @return |
||
| 152 | -32x | +
- in_rows(.list = y[[.stats]], .formats = .formats[[.stats]])+ #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions, |
|
| 153 |
- }+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 154 |
-
+ #' the statistics from `s_count_patients_with_event()` to the table layout. |
||
| 155 |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ #' |
||
| 156 |
- #' function arguments and additional format arguments. This function is a wrapper for+ #' @examples |
||
| 157 |
- #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()].+ #' lyt <- basic_table() %>% |
||
| 158 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 159 |
- #' @return+ #' add_colcounts() %>% |
||
| 160 |
- #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ #' count_values( |
||
| 161 |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ #' "STUDYID", |
||
| 162 |
- #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ #' values = "AB12345", |
||
| 163 |
- #' columns, to the table layout.+ #' .stats = "count", |
||
| 164 |
- #'+ #' .labels = c(count = "Total AEs") |
||
| 165 |
- #' @examples+ #' ) %>% |
||
| 166 |
- #' lyt5 <- basic_table() %>%+ #' count_patients_with_event( |
||
| 167 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)+ #' "SUBJID", |
||
| 168 |
- #'+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 169 |
- #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl)+ #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"), |
||
| 170 |
- #' result5+ #' table_names = "tbl_all" |
||
| 171 |
- #'+ #' ) %>% |
||
| 172 |
- #' lyt6 <- basic_table() %>%+ #' count_patients_with_event( |
||
| 173 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")+ #' "SUBJID", |
||
| 174 |
- #'+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 175 |
- #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl)+ #' .labels = c(count_fraction = "Total number of patients with fatal AEs"), |
||
| 176 |
- #' result6+ #' table_names = "tbl_fatal" |
||
| 177 |
- #'+ #' ) %>% |
||
| 178 |
- #' @export+ #' count_patients_with_event( |
||
| 179 |
- #' @order 3+ #' "SUBJID", |
||
| 180 |
- summarize_patients_exposure_in_cols <- function(lyt, # nolint+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
|
||
| 181 |
- var,+ #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"), |
||
| 182 |
- ex_var = "AVAL",+ #' .indent_mods = c(count_fraction = 2L), |
||
| 183 |
- id = "USUBJID",+ #' table_names = "tbl_rel_fatal" |
||
| 184 |
- add_total_level = FALSE,+ #' ) |
||
| 185 |
- custom_label = NULL,+ #' |
||
| 186 |
- col_split = TRUE,+ #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) |
||
| 187 |
- na_str = default_na_str(),+ #' |
||
| 188 |
- ...,+ #' @export |
||
| 189 |
- .stats = c("n_patients", "sum_exposure"),
+ #' @order 2 |
||
| 190 |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ count_patients_with_event <- function(lyt, |
||
| 191 |
- .indent_mods = NULL) {
+ vars, |
||
| 192 | -3x | +
- extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...)+ filters, |
|
| 193 |
-
+ riskdiff = FALSE, |
||
| 194 | -3x | +
- if (col_split) {
+ na_str = default_na_str(), |
|
| 195 | -3x | +
- lyt <- split_cols_by_multivar(+ nested = TRUE, |
|
| 196 | -3x | +
- lyt = lyt,+ ..., |
|
| 197 | -3x | +
- vars = rep(var, length(.stats)),+ table_names = vars, |
|
| 198 | -3x | +
- varlabels = .labels[.stats],+ .stats = "count_fraction", |
|
| 199 | -3x | +
- extra_args = list(.stats = .stats)+ .formats = list(count_fraction = format_count_fraction_fixed_dp), |
|
| 200 |
- )+ .labels = NULL, |
||
| 201 |
- }+ .indent_mods = NULL) {
|
||
| 202 | -3x | +7x |
- summarize_row_groups(+ checkmate::assert_flag(riskdiff) |
| 203 | -3x | +7x |
- lyt = lyt,+ extra_args <- list( |
| 204 | -3x | +7x |
- var = var,+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 205 | -3x | +
- cfun = a_count_patients_sum_exposure,+ ) |
|
| 206 | -3x | +7x |
- na_str = na_str,+ s_args <- list(filters = filters, ...) |
| 207 | -3x | +
- extra_args = extra_args+ |
|
| 208 | -+ | 7x |
- )+ if (isFALSE(riskdiff)) {
|
| 209 | -+ | 5x |
- }+ extra_args <- c(extra_args, s_args) |
| 210 |
-
+ } else {
|
||
| 211 | -+ | 2x |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ extra_args <- c( |
| 212 | -+ | 2x |
- #' function arguments and additional format arguments. This function is a wrapper for+ extra_args, |
| 213 | -+ | 2x |
- #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].+ list( |
| 214 | -+ | 2x |
- #'+ afun = list("s_count_patients_with_event" = a_count_patients_with_event),
|
| 215 | -+ | 2x |
- #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required+ s_args = s_args |
| 216 |
- #' column split has been done already earlier in the layout pipe.+ ) |
||
| 217 |
- #'+ ) |
||
| 218 |
- #' @return+ } |
||
| 219 |
- #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ |
||
| 220 | -+ | 7x |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ analyze( |
| 221 | -+ | 7x |
- #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ lyt = lyt, |
| 222 | -+ | 7x |
- #' columns, to the table layout.+ vars = vars, |
| 223 | -+ | 7x |
- #'+ afun = ifelse(isFALSE(riskdiff), a_count_patients_with_event, afun_riskdiff), |
| 224 | -+ | 7x |
- #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows,+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 225 | -+ | 7x |
- #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple+ table_names = table_names, |
| 226 | -+ | 7x |
- #' pages when pagination is used.+ na_str = na_str, |
| 227 | -+ | 7x |
- #'+ nested = nested, |
| 228 | -+ | 7x |
- #' @examples+ extra_args = extra_args |
| 229 |
- #' set.seed(1)+ ) |
||
| 230 |
- #' df <- data.frame(+ } |
| 231 | +1 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ #' Subgroup treatment effect pattern (STEP) fit for binary (response) outcome |
|
| 232 | +2 |
- #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
+ #' |
|
| 233 | +3 |
- #' SEX = c(rep("Female", 6), rep("Male", 6)),
+ #' @description `r lifecycle::badge("stable")`
|
|
| 234 | +4 |
- #' AVAL = as.numeric(sample(seq(1, 20), 12)),+ #' |
|
| 235 | +5 |
- #' stringsAsFactors = TRUE+ #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary |
|
| 236 | +6 |
- #' )+ #' (response) outcome. The treatment arm variable must have exactly 2 levels, |
|
| 237 | +7 |
- #' adsl <- data.frame(+ #' where the first one is taken as reference and the estimated odds ratios are |
|
| 238 | +8 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ #' for the comparison of the second level vs. the first one. |
|
| 239 | +9 |
- #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
+ #' |
|
| 240 | +10 |
- #' SEX = c(rep("Female", 2), rep("Male", 2)),
+ #' The (conditional) logistic regression model which is fit is: |
|
| 241 | +11 |
- #' stringsAsFactors = TRUE+ #' |
|
| 242 | +12 |
- #' )+ #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
|
| 243 | +13 |
#' |
|
| 244 | +14 |
- #' lyt <- basic_table() %>%+ #' where `degree` is specified by `control_step()`. |
|
| 245 | +15 |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ #' |
|
| 246 | +16 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%+ #' @inheritParams argument_convention |
|
| 247 | +17 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE)+ #' @param variables (named `list` of `character`)\cr list of analysis variables: |
|
| 248 | +18 |
- #' result <- build_table(lyt, df = df, alt_counts_df = adsl)+ #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`. |
|
| 249 | +19 |
- #' result+ #' @param control (named `list`)\cr combined control list from [control_step()] |
|
| 250 | +20 | ++ |
+ #' and [control_logistic()].+ |
+
| 21 |
#' |
||
| 251 | +22 |
- #' lyt2 <- basic_table() %>%+ #' @return A matrix of class `step`. The first part of the columns describe the |
|
| 252 | +23 |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ #' subgroup intervals used for the biomarker variable, including where the |
|
| 253 | +24 |
- #' summarize_patients_exposure_in_cols(+ #' center of the intervals are and their bounds. The second part of the |
|
| 254 | +25 |
- #' var = "AVAL", col_split = TRUE,+ #' columns contain the estimates for the treatment arm comparison. |
|
| 255 | +26 |
- #' .stats = "n_patients", custom_label = "some custom label"+ #' |
|
| 256 | +27 |
- #' ) %>%+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
|
| 257 | +28 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL")+ #' |
|
| 258 | +29 |
- #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)+ #' @seealso [control_step()] and [control_logistic()] for the available |
|
| 259 | +30 |
- #' result2+ #' customization options. |
|
| 260 | +31 |
#' |
|
| 261 | +32 |
- #' lyt3 <- basic_table() %>%+ #' @examples |
|
| 262 | +33 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL")+ #' # Testing dataset with just two treatment arms. |
|
| 263 | +34 |
- #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)+ #' library(survival) |
|
| 264 | +35 |
- #' result3+ #' library(dplyr) |
|
| 265 | +36 |
#' |
|
| 266 | +37 |
- #' # Adding total levels and custom label+ #' adrs_f <- tern_ex_adrs %>% |
|
| 267 | +38 |
- #' lyt4 <- basic_table(+ #' filter( |
|
| 268 | +39 |
- #' show_colcounts = TRUE+ #' PARAMCD == "BESRSPI", |
|
| 269 | +40 |
- #' ) %>%+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
|
| 270 | +41 |
- #' analyze_patients_exposure_in_cols(+ #' ) %>% |
|
| 271 | +42 |
- #' var = "ARMCD",+ #' mutate( |
|
| 272 | +43 |
- #' col_split = TRUE,+ #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations. |
|
| 273 | +44 |
- #' add_total_level = TRUE,+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
|
| 274 | +45 |
- #' custom_label = "TOTAL"+ #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
|
| 275 | +46 |
- #' ) %>%+ #' SEX = factor(SEX) |
|
| 276 | +47 |
- #' append_topleft(c("", "Sex"))
+ #' ) |
|
| 277 | +48 |
#' |
|
| 278 | +49 |
- #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)+ #' variables <- list( |
|
| 279 | +50 |
- #' result4+ #' arm = "ARM", |
|
| 280 | +51 |
- #'+ #' biomarker = "BMRKR1", |
|
| 281 | +52 |
- #' @export+ #' covariates = "AGE", |
|
| 282 | +53 |
- #' @order 2+ #' response = "RSP" |
|
| 283 | +54 |
- analyze_patients_exposure_in_cols <- function(lyt, # nolint+ #' ) |
|
| 284 | +55 |
- var = NULL,+ #' |
|
| 285 | +56 |
- ex_var = "AVAL",+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
|
| 286 | +57 |
- id = "USUBJID",+ #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those. |
|
| 287 | +58 |
- add_total_level = FALSE,+ #' step_matrix <- fit_rsp_step( |
|
| 288 | +59 |
- custom_label = NULL,+ #' variables = variables, |
|
| 289 | +60 |
- col_split = TRUE,+ #' data = adrs_f, |
|
| 290 | +61 |
- na_str = default_na_str(),+ #' control = c(control_logistic(), control_step(bandwidth = 0.9)) |
|
| 291 | +62 |
- .stats = c("n_patients", "sum_exposure"),
+ #' ) |
|
| 292 | +63 |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ #' dim(step_matrix) |
|
| 293 | +64 |
- .indent_mods = 0L,+ #' head(step_matrix) |
|
| 294 | +65 |
- ...) {
+ #' |
|
| 295 | -6x | +||
| 66 | +
- extra_args <- list(+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
||
| 296 | -6x | +||
| 67 | +
- var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...+ #' # models. Or specify different logistic regression options, including confidence level. |
||
| 297 | +68 |
- )+ #' step_matrix2 <- fit_rsp_step( |
|
| 298 | +69 |
-
+ #' variables = variables, |
|
| 299 | -6x | +||
| 70 | +
- if (col_split) {
+ #' data = adrs_f, |
||
| 300 | -4x | +||
| 71 | +
- lyt <- split_cols_by_multivar(+ #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = NULL, degree = 1)) |
||
| 301 | -4x | +||
| 72 | +
- lyt = lyt,+ #' ) |
||
| 302 | -4x | +||
| 73 | +
- vars = rep(ex_var, length(.stats)),+ #' |
||
| 303 | -4x | +||
| 74 | +
- varlabels = .labels[.stats],+ #' # Use a global constant model. This is helpful as a reference for the subgroup models. |
||
| 304 | -4x | +||
| 75 | +
- extra_args = list(.stats = .stats)+ #' step_matrix3 <- fit_rsp_step( |
||
| 305 | +76 |
- )+ #' variables = variables, |
|
| 306 | +77 |
- }+ #' data = adrs_f, |
|
| 307 | -6x | +||
| 78 | +
- lyt <- lyt %>% analyze_colvars(+ #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L)) |
||
| 308 | -6x | +||
| 79 | +
- afun = a_count_patients_sum_exposure,+ #' ) |
||
| 309 | -6x | +||
| 80 | +
- indent_mod = .indent_mods,+ #' |
||
| 310 | -6x | +||
| 81 | +
- na_str = na_str,+ #' # It is also possible to use strata, i.e. use conditional logistic regression models. |
||
| 311 | -6x | +||
| 82 | +
- extra_args = extra_args+ #' variables2 <- list( |
||
| 312 | +83 |
- )+ #' arm = "ARM", |
|
| 313 | -6x | +||
| 84 | +
- lyt+ #' biomarker = "BMRKR1", |
||
| 314 | +85 |
- }+ #' covariates = "AGE", |
| 1 | +86 |
- #' Control function for Cox regression+ #' response = "RSP", |
||
| 2 | +87 |
- #'+ #' strata = c("STRATA1", "STRATA2")
|
||
| 3 | +88 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 4 | +89 |
#' |
||
| 5 | +90 |
- #' Sets a list of parameters for Cox regression fit. Used internally.+ #' step_matrix4 <- fit_rsp_step( |
||
| 6 | +91 |
- #'+ #' variables = variables2, |
||
| 7 | +92 |
- #' @inheritParams argument_convention+ #' data = adrs_f, |
||
| 8 | +93 |
- #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ #' control = c(control_logistic(), control_step(bandwidth = NULL)) |
||
| 9 | +94 |
- #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied+ #' ) |
||
| 10 | +95 |
- #' treatment and candidate covariate. Note that for univariate models without treatment arm, and+ #' |
||
| 11 | +96 |
- #' multivariate models, no interaction can be used so that this needs to be `FALSE`.+ #' @export |
||
| 12 | +97 |
- #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`,+ fit_rsp_step <- function(variables, |
||
| 13 | +98 |
- #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R.+ data, |
||
| 14 | +99 |
- #'+ control = c(control_step(), control_logistic())) {
|
||
| 15 | -+ | |||
| 100 | +5x |
- #' @return A `list` of items with names corresponding to the arguments.+ assert_df_with_variables(data, variables) |
||
| 16 | -+ | |||
| 101 | +5x |
- #'+ checkmate::assert_list(control, names = "named") |
||
| 17 | -+ | |||
| 102 | +5x |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ data <- data[!is.na(data[[variables$biomarker]]), ] |
||
| 18 | -+ | |||
| 103 | +5x |
- #'+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
||
| 19 | -+ | |||
| 104 | +5x |
- #' @examples+ interval_center <- window_sel$interval[, "Interval Center"] |
||
| 20 | -+ | |||
| 105 | +5x |
- #' control_coxreg()+ form <- h_step_rsp_formula(variables = variables, control = control) |
||
| 21 | -+ | |||
| 106 | +5x |
- #'+ estimates <- if (is.null(control$bandwidth)) {
|
||
| 22 | -+ | |||
| 107 | +1x |
- #' @export+ h_step_rsp_est( |
||
| 23 | -+ | |||
| 108 | +1x |
- control_coxreg <- function(pval_method = c("wald", "likelihood"),
+ formula = form, |
||
| 24 | -+ | |||
| 109 | +1x |
- ties = c("exact", "efron", "breslow"),
+ data = data,+ |
+ ||
| 110 | +1x | +
+ variables = variables,+ |
+ ||
| 111 | +1x | +
+ x = interval_center,+ |
+ ||
| 112 | +1x | +
+ control = control |
||
| 25 | +113 |
- conf_level = 0.95,+ ) |
||
| 26 | +114 |
- interaction = FALSE) {
+ } else {
|
||
| 27 | -55x | +115 | +4x |
- pval_method <- match.arg(pval_method)+ tmp <- mapply( |
| 28 | -55x | +116 | +4x |
- ties <- match.arg(ties)+ FUN = h_step_rsp_est, |
| 29 | -55x | +117 | +4x |
- checkmate::assert_flag(interaction)+ x = interval_center, |
| 30 | -55x | +118 | +4x |
- assert_proportion_value(conf_level)+ subset = as.list(as.data.frame(window_sel$sel)), |
| 31 | -55x | +119 | +4x |
- list(+ MoreArgs = list( |
| 32 | -55x | +120 | +4x |
- pval_method = pval_method,+ formula = form, |
| 33 | -55x | +121 | +4x |
- ties = ties,+ data = data, |
| 34 | -55x | +122 | +4x |
- conf_level = conf_level,+ variables = variables, |
| 35 | -55x | +123 | +4x |
- interaction = interaction+ control = control |
| 36 | +124 |
- )+ ) |
||
| 37 | +125 |
- }+ ) |
||
| 38 | +126 |
-
+ # Maybe we find a more elegant solution than this. |
||
| 39 | -+ | |||
| 127 | +4x |
- #' Custom tidy methods for Cox regression+ rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
|
||
| 40 | -+ | |||
| 128 | +4x |
- #'+ t(tmp) |
||
| 41 | +129 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 42 | -+ | |||
| 130 | +5x |
- #'+ result <- cbind(window_sel$interval, estimates) |
||
| 43 | -+ | |||
| 131 | +5x |
- #' @inheritParams argument_convention+ structure( |
||
| 44 | -+ | |||
| 132 | +5x |
- #' @param x (`list`)\cr result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models)+ result, |
||
| 45 | -+ | |||
| 133 | +5x |
- #' or [fit_coxreg_multivar()] (for multivariate models).+ class = c("step", "matrix"),
|
||
| 46 | -+ | |||
| 134 | +5x |
- #'+ variables = variables, |
||
| 47 | -+ | |||
| 135 | +5x |
- #' @return [broom::tidy()] returns:+ control = control |
||
| 48 | +136 |
- #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`,+ ) |
||
| 49 | +137 |
- #' `upper .95`, `level`, and `n`.+ } |
| 50 | +1 |
- #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`,+ #' Sort pharmacokinetic data by `PARAM` variable |
|
| 51 | +2 |
- #' `lcl`, `ucl`, `pval`, and `ci`.+ #' |
|
| 52 | +3 |
- #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`,+ #' @description `r lifecycle::badge("stable")`
|
|
| 53 | +4 |
- #' `level`, and `ci`.+ #' |
|
| 54 | +5 |
- #'+ #' @param pk_data (`data.frame`)\cr pharmacokinetic data frame. |
|
| 55 | +6 |
- #' @seealso [cox_regression]+ #' @param key_var (`string`)\cr key variable used to merge pk_data and metadata created by [d_pkparam()]. |
|
| 56 | +7 |
#' |
|
| 57 | +8 |
- #' @name tidy_coxreg+ #' @return A pharmacokinetic `data.frame` sorted by a `PARAM` variable. |
|
| 58 | +9 |
- NULL+ #' |
|
| 59 | +10 |
-
+ #' @examples |
|
| 60 | +11 |
- #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results.+ #' library(dplyr) |
|
| 61 | +12 |
#' |
|
| 62 | +13 |
- #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results.+ #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
|
|
| 63 | +14 |
- #'+ #' pk_ordered_data <- h_pkparam_sort(adpp) |
|
| 64 | +15 |
- #' @method tidy summary.coxph+ #' |
|
| 65 | +16 |
- #'+ #' @export |
|
| 66 | +17 |
- #' @examples+ h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
|
|
| 67 | -+ | ||
| 18 | +4x |
- #' library(survival)+ assert_df_with_variables(pk_data, list(key_var = key_var)) |
|
| 68 | -+ | ||
| 19 | +4x |
- #' library(broom)+ pk_data$PARAMCD <- pk_data[[key_var]] |
|
| 69 | +20 |
- #'+ |
|
| 70 | -+ | ||
| 21 | +4x |
- #' set.seed(1, kind = "Mersenne-Twister")+ ordered_pk_data <- d_pkparam() |
|
| 71 | +22 |
- #'+ |
|
| 72 | +23 |
- #' dta_bladder <- with(+ # Add the numeric values from ordered_pk_data to pk_data |
|
| 73 | -+ | ||
| 24 | +4x |
- #' data = bladder[bladder$enum < 5, ],+ joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffixes = c("", ".y"))
|
|
| 74 | +25 |
- #' data.frame(+ |
|
| 75 | -+ | ||
| 26 | +4x |
- #' time = stop,+ joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
|
|
| 76 | +27 |
- #' status = event,+ |
|
| 77 | -+ | ||
| 28 | +4x |
- #' armcd = as.factor(rx),+ joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER) |
|
| 78 | +29 |
- #' covar1 = as.factor(enum),+ |
|
| 79 | +30 |
- #' covar2 = factor(+ # Then order PARAM based on this column |
|
| 80 | -+ | ||
| 31 | +4x |
- #' sample(as.factor(enum)),+ joined_data$PARAM <- factor(joined_data$PARAM, |
|
| 81 | -+ | ||
| 32 | +4x |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]), |
|
| 82 | -+ | ||
| 33 | +4x |
- #' )+ ordered = TRUE |
|
| 83 | +34 |
- #' )+ ) |
|
| 84 | +35 |
- #' )+ |
|
| 85 | -+ | ||
| 36 | +4x |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY, |
|
| 86 | -+ | ||
| 37 | +4x |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]), |
|
| 87 | -+ | ||
| 38 | +4x |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ ordered = TRUE |
|
| 88 | +39 |
- #'+ ) |
|
| 89 | +40 |
- #' formula <- "survival::Surv(time, status) ~ armcd + covar1"+ + |
+ |
| 41 | +4x | +
+ joined_data |
|
| 90 | +42 |
- #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder))+ } |
| 91 | +1 |
- #' tidy(msum)+ #' Count patients by most extreme post-baseline toxicity grade per direction of abnormality |
||
| 92 | +2 |
#' |
||
| 93 | +3 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 94 | +4 |
- tidy.summary.coxph <- function(x, # nolint+ #' |
||
| 95 | +5 |
- ...) {
+ #' The analyze function [count_abnormal_by_worst_grade()] creates a layout element to count patients by highest (worst) |
||
| 96 | -199x | +|||
| 6 | +
- checkmate::assert_class(x, "summary.coxph")+ #' analysis toxicity grade post-baseline for each direction, categorized by parameter value. |
|||
| 97 | -199x | +|||
| 7 | +
- pval <- x$coefficients+ #' |
|||
| 98 | -199x | +|||
| 8 | +
- confint <- x$conf.int+ #' This function analyzes primary analysis variable `var` which indicates toxicity grades. Additional |
|||
| 99 | -199x | +|||
| 9 | +
- levels <- rownames(pval)+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
|||
| 100 | +10 |
-
+ #' `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a variable |
||
| 101 | -199x | +|||
| 11 | +
- pval <- tibble::as_tibble(pval)+ #' to indicate parameter values, and `grade_dir` (defaults to `GRADE_DIR`), a variable to indicate directions |
|||
| 102 | -199x | +|||
| 12 | +
- confint <- tibble::as_tibble(confint)+ #' (e.g. High or Low) for each toxicity grade supplied in `var`. |
|||
| 103 | +13 |
-
+ #' |
||
| 104 | -199x | +|||
| 14 | +
- ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
+ #' For each combination of `param` and `grade_dir` levels, patient counts by worst |
|||
| 105 | -199x | +|||
| 15 | +
- ret$level <- levels+ #' grade are calculated as follows: |
|||
| 106 | -199x | +|||
| 16 | +
- ret$n <- x[["n"]]+ #' * `1` to `4`: The number of patients with worst grades 1-4, respectively. |
|||
| 107 | -199x | +|||
| 17 | +
- ret+ #' * `Any`: The number of patients with at least one abnormality (i.e. grade is not 0). |
|||
| 108 | +18 |
- }+ #' |
||
| 109 | +19 |
-
+ #' Fractions are calculated by dividing the above counts by the number of patients with at least one |
||
| 110 | +20 |
- #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression.+ #' valid measurement recorded during treatment. |
||
| 111 | +21 |
#' |
||
| 112 | +22 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()].+ #' Pre-processing is crucial when using this function and can be done automatically using the |
||
| 113 | +23 |
- #'+ #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the |
||
| 114 | +24 |
- #' @method tidy coxreg.univar+ #' necessary pre-processing steps. |
||
| 115 | +25 |
#' |
||
| 116 | +26 |
- #' @examples+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two row |
||
| 117 | +27 |
- #' ## Cox regression: arm + 1 covariate.+ #' splits, one on variable `param` and one on variable `grade_dir`. |
||
| 118 | +28 |
- #' mod1 <- fit_coxreg_univar(+ #' |
||
| 119 | +29 |
- #' variables = list(+ #' @inheritParams argument_convention |
||
| 120 | +30 |
- #' time = "time", event = "status", arm = "armcd",+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 121 | +31 |
- #' covariates = "covar1"+ #' |
||
| 122 | +32 |
- #' ),+ #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade"))``
|
||
| 123 | +33 |
- #' data = dta_bladder,+ #' |
||
| 124 | +34 |
- #' control = control_coxreg(conf_level = 0.91)+ #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes ADLB data frames to be used in |
||
| 125 | +35 |
- #' )+ #' [count_abnormal_by_worst_grade()]. |
||
| 126 | +36 |
#' |
||
| 127 | +37 |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ #' @name abnormal_by_worst_grade |
||
| 128 | +38 |
- #' mod2 <- fit_coxreg_univar(+ #' @order 1 |
||
| 129 | +39 |
- #' variables = list(+ NULL |
||
| 130 | +40 |
- #' time = "time", event = "status", arm = "armcd",+ |
||
| 131 | +41 |
- #' covariates = c("covar1", "covar2")
+ #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade. |
||
| 132 | +42 |
- #' ),+ #' |
||
| 133 | +43 |
- #' data = dta_bladder,+ #' @return |
||
| 134 | +44 |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and |
||
| 135 | +45 |
- #' )+ #' "Any" results. |
||
| 136 | +46 |
#' |
||
| 137 | +47 |
- #' tidy(mod1)+ #' @keywords internal |
||
| 138 | +48 |
- #' tidy(mod2)+ s_count_abnormal_by_worst_grade <- function(df, # nolint |
||
| 139 | +49 |
- #'+ .var = "GRADE_ANL", |
||
| 140 | +50 |
- #' @export+ .spl_context, |
||
| 141 | +51 |
- tidy.coxreg.univar <- function(x, # nolint+ variables = list( |
||
| 142 | +52 |
- ...) {
+ id = "USUBJID", |
||
| 143 | -38x | +|||
| 53 | +
- checkmate::assert_class(x, "coxreg.univar")+ param = "PARAM", |
|||
| 144 | -38x | +|||
| 54 | +
- mod <- x$mod+ grade_dir = "GRADE_DIR" |
|||
| 145 | -38x | +|||
| 55 | +
- vars <- c(x$vars$arm, x$vars$covariates)+ )) {
|
|||
| 146 | -38x | +56 | +1x |
- has_arm <- "arm" %in% names(x$vars)+ checkmate::assert_string(.var) |
| 147 | -+ | |||
| 57 | +1x |
-
+ assert_valid_factor(df[[.var]]) |
||
| 148 | -38x | +58 | +1x |
- result <- if (!has_arm) {
+ assert_valid_factor(df[[variables$param]]) |
| 149 | -5x | +59 | +1x |
- Map(+ assert_valid_factor(df[[variables$grade_dir]]) |
| 150 | -5x | +60 | +1x |
- mod = mod, vars = vars,+ assert_df_with_variables(df, c(a = .var, variables)) |
| 151 | -5x | +61 | +1x |
- f = function(mod, vars) {
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 152 | -6x | +|||
| 62 | +
- h_coxreg_multivar_extract(+ |
|||
| 153 | -6x | +|||
| 63 | +
- var = vars,+ # To verify that the `split_rows_by` are performed with correct variables. |
|||
| 154 | -6x | +64 | +1x |
- data = x$data,+ checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split) |
| 155 | -6x | +65 | +1x |
- mod = mod,+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
| 156 | -6x | -
- control = x$control- |
- ||
| 157 | -+ | 66 | +1x |
- )+ x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any") |
| 158 | -+ | |||
| 67 | +1x |
- }+ result <- split(numeric(0), factor(x_lvls)) |
||
| 159 | +68 |
- )- |
- ||
| 160 | -38x | -
- } else if (x$control$interaction) {
- |
- ||
| 161 | -12x | -
- Map(- |
- ||
| 162 | -12x | -
- mod = mod, covar = vars,- |
- ||
| 163 | -12x | -
- f = function(mod, covar) {
- |
- ||
| 164 | -26x | -
- h_coxreg_extract_interaction(+ |
||
| 165 | -26x | +69 | +1x |
- effect = x$vars$arm, covar = covar, mod = mod, data = x$data,+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
| 166 | -26x | +70 | +1x |
- at = x$at, control = x$control+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
| 167 | +71 |
- )+ # Some subjects may have a record for high and low directions but |
||
| 168 | +72 |
- }+ # should be counted only once. |
||
| 169 | -+ | |||
| 73 | +1x |
- )+ denom <- length(unique(subj_cur_col)) |
||
| 170 | +74 |
- } else {
- |
- ||
| 171 | -21x | -
- Map(- |
- ||
| 172 | -21x | -
- mod = mod, vars = vars,- |
- ||
| 173 | -21x | -
- f = function(mod, vars) {
+
|
||
| 174 | -53x | +75 | +1x |
- h_coxreg_univar_extract(+ for (lvl in x_lvls) {
|
| 175 | -53x | +76 | +5x |
- effect = x$vars$arm, covar = vars, data = x$data, mod = mod,+ if (lvl != "Any") {
|
| 176 | -53x | -
- control = x$control- |
- ||
| 177 | -- |
- )- |
- ||
| 178 | -- |
- }- |
- ||
| 179 | -+ | 77 | +4x |
- )+ df_lvl <- df[df[[.var]] == lvl, ] |
| 180 | +78 |
- }+ } else {
|
||
| 181 | -38x | +79 | +1x |
- result <- do.call(rbind, result)+ df_lvl <- df[df[[.var]] != 0, ] |
| 182 | +80 | - - | -||
| 183 | -38x | -
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))- |
- ||
| 184 | -38x | -
- result$n <- lapply(result$n, empty_vector_if_na)- |
- ||
| 185 | -38x | -
- result$ci <- lapply(result$ci, empty_vector_if_na)+ } |
||
| 186 | -38x | +81 | +5x |
- result$hr <- lapply(result$hr, empty_vector_if_na)+ num <- length(unique(df_lvl[[variables[["id"]]]])) |
| 187 | -38x | +82 | +5x |
- if (x$control$interaction) {
+ fraction <- ifelse(denom == 0, 0, num / denom) |
| 188 | -12x | +83 | +5x |
- result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na)+ result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl) |
| 189 | +84 |
- # Remove interaction p-values due to change in specifications.- |
- ||
| 190 | -12x | -
- result$pval[result$effect != "Treatment:"] <- NA+ } |
||
| 191 | +85 |
- }- |
- ||
| 192 | -38x | -
- result$pval <- lapply(result$pval, empty_vector_if_na)+ |
||
| 193 | -38x | +86 | +1x |
- attr(result, "conf_level") <- x$control$conf_level+ result <- list(count_fraction = result) |
| 194 | -38x | +87 | +1x |
result |
| 195 | +88 |
} |
||
| 196 | +89 | |||
| 197 | +90 |
- #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression.+ #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun` |
||
| 198 | +91 |
- #'+ #' in `count_abnormal_by_worst_grade()`. |
||
| 199 | +92 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()].+ #' |
||
| 200 | +93 |
- #'+ #' @return |
||
| 201 | +94 |
- #' @method tidy coxreg.multivar+ #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 202 | +95 |
#' |
||
| 203 | +96 |
- #' @examples+ #' @keywords internal |
||
| 204 | +97 |
- #' multivar_model <- fit_coxreg_multivar(+ a_count_abnormal_by_worst_grade <- make_afun( # nolint |
||
| 205 | +98 |
- #' variables = list(+ s_count_abnormal_by_worst_grade, |
||
| 206 | +99 |
- #' time = "time", event = "status", arm = "armcd",+ .formats = c(count_fraction = format_count_fraction) |
||
| 207 | +100 |
- #' covariates = c("covar1", "covar2")
+ ) |
||
| 208 | +101 |
- #' ),+ |
||
| 209 | +102 |
- #' data = dta_bladder+ #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments |
||
| 210 | +103 |
- #' )+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 211 | +104 |
- #' broom::tidy(multivar_model)+ #' |
||
| 212 | +105 |
- #'+ #' @return |
||
| 213 | +106 |
- #' @export+ #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 214 | +107 |
- tidy.coxreg.multivar <- function(x, # nolint+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 215 | +108 |
- ...) {
- |
- ||
| 216 | -16x | -
- checkmate::assert_class(x, "coxreg.multivar")- |
- ||
| 217 | -16x | -
- vars <- c(x$vars$arm, x$vars$covariates)+ #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout. |
||
| 218 | +109 |
-
+ #' |
||
| 219 | +110 |
- # Convert the model summaries to data.- |
- ||
| 220 | -16x | -
- result <- Map(- |
- ||
| 221 | -16x | -
- vars = vars,- |
- ||
| 222 | -16x | -
- f = function(vars) {
- |
- ||
| 223 | -60x | -
- h_coxreg_multivar_extract(- |
- ||
| 224 | -60x | -
- var = vars, data = x$data,- |
- ||
| 225 | -60x | -
- mod = x$mod, control = x$control+ #' @examples |
||
| 226 | +111 |
- )+ #' library(dplyr) |
||
| 227 | +112 |
- }+ #' library(forcats) |
||
| 228 | +113 |
- )- |
- ||
| 229 | -16x | -
- result <- do.call(rbind, result)+ #' adlb <- tern_ex_adlb |
||
| 230 | +114 | - - | -||
| 231 | -16x | -
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))- |
- ||
| 232 | -16x | -
- result$ci <- lapply(result$ci, empty_vector_if_na)+ #' |
||
| 233 | -16x | +|||
| 115 | +
- result$hr <- lapply(result$hr, empty_vector_if_na)+ #' # Data is modified in order to have some parameters with grades only in one direction |
|||
| 234 | -16x | +|||
| 116 | +
- result$pval <- lapply(result$pval, empty_vector_if_na)+ #' # and simulate the real data. |
|||
| 235 | -16x | +|||
| 117 | +
- result <- result[, names(result) != "n"]+ #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
|
|||
| 236 | -16x | +|||
| 118 | +
- attr(result, "conf_level") <- x$control$conf_level+ #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW" |
|||
| 237 | +119 |
-
+ #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- "" |
||
| 238 | -16x | +|||
| 120 | +
- result+ #' |
|||
| 239 | +121 |
- }+ #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
|
||
| 240 | +122 |
-
+ #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH" |
||
| 241 | +123 |
- #' Fitting functions for Cox proportional hazards regression+ #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- "" |
||
| 242 | +124 |
#' |
||
| 243 | +125 |
- #' @description `r lifecycle::badge("stable")`
+ #' # Pre-processing |
||
| 244 | +126 |
- #'+ #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade() |
||
| 245 | +127 |
- #' Fitting functions for univariate and multivariate Cox regression models.+ #' |
||
| 246 | +128 |
- #'+ #' # Map excludes records without abnormal grade since they should not be displayed |
||
| 247 | +129 |
- #' @param variables (named `list`)\cr the names of the variables found in `data`, passed as a named list and+ #' # in the table. |
||
| 248 | +130 |
- #' corresponding to the `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from+ #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
|
||
| 249 | +131 |
- #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect+ #' lapply(as.character) %>% |
||
| 250 | +132 |
- #' estimates will be tabulated later.+ #' as.data.frame() %>% |
||
| 251 | +133 |
- #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models.+ #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL) |
||
| 252 | +134 |
- #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify+ #' |
||
| 253 | +135 |
- #' the value of the covariate at which the effect should be estimated.+ #' basic_table() %>% |
||
| 254 | +136 |
- #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()].+ #' split_cols_by("ARMCD") %>%
|
||
| 255 | +137 |
- #'+ #' split_rows_by("PARAM") %>%
|
||
| 256 | +138 |
- #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression].+ #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
|
||
| 257 | +139 |
- #'+ #' count_abnormal_by_worst_grade( |
||
| 258 | +140 |
- #' @examples+ #' var = "GRADE_ANL", |
||
| 259 | +141 |
- #' library(survival)+ #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR") |
||
| 260 | +142 |
- #'+ #' ) %>% |
||
| 261 | +143 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' build_table(df = adlb_f) |
||
| 262 | +144 |
#' |
||
| 263 | +145 |
- #' # Testing dataset [survival::bladder].+ #' @export |
||
| 264 | +146 |
- #' dta_bladder <- with(+ #' @order 2 |
||
| 265 | +147 |
- #' data = bladder[bladder$enum < 5, ],+ count_abnormal_by_worst_grade <- function(lyt, |
||
| 266 | +148 |
- #' data.frame(+ var, |
||
| 267 | +149 |
- #' time = stop,+ variables = list( |
||
| 268 | +150 |
- #' status = event,+ id = "USUBJID", |
||
| 269 | +151 |
- #' armcd = as.factor(rx),+ param = "PARAM", |
||
| 270 | +152 |
- #' covar1 = as.factor(enum),+ grade_dir = "GRADE_DIR" |
||
| 271 | +153 |
- #' covar2 = factor(+ ), |
||
| 272 | +154 |
- #' sample(as.factor(enum)),+ na_str = default_na_str(), |
||
| 273 | +155 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ nested = TRUE, |
||
| 274 | +156 |
- #' )+ ..., |
||
| 275 | +157 |
- #' )+ .stats = NULL, |
||
| 276 | +158 |
- #' )+ .formats = NULL, |
||
| 277 | +159 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ .labels = NULL, |
||
| 278 | +160 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ .indent_mods = NULL) {
|
||
| 279 | -+ | |||
| 161 | +2x |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ extra_args <- list(variables = variables, ...) |
||
| 280 | +162 |
- #'+ |
||
| 281 | -+ | |||
| 163 | +2x |
- #' plot(+ afun <- make_afun( |
||
| 282 | -+ | |||
| 164 | +2x |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ a_count_abnormal_by_worst_grade, |
||
| 283 | -+ | |||
| 165 | +2x |
- #' lty = 2:4,+ .stats = .stats, |
||
| 284 | -+ | |||
| 166 | +2x |
- #' xlab = "Months",+ .formats = .formats, |
||
| 285 | -+ | |||
| 167 | +2x |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ .labels = .labels, |
||
| 286 | -+ | |||
| 168 | +2x |
- #' )+ .indent_mods = .indent_mods, |
||
| 287 | -+ | |||
| 169 | +2x |
- #'+ .ungroup_stats = "count_fraction" |
||
| 288 | +170 |
- #' @name fit_coxreg+ ) |
||
| 289 | -+ | |||
| 171 | +2x |
- NULL+ analyze( |
||
| 290 | -+ | |||
| 172 | +2x |
-
+ lyt = lyt, |
||
| 291 | -+ | |||
| 173 | +2x |
- #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs.+ vars = var, |
||
| 292 | -+ | |||
| 174 | +2x |
- #'+ afun = afun, |
||
| 293 | -+ | |||
| 175 | +2x |
- #' @return+ na_str = na_str, |
||
| 294 | -+ | |||
| 176 | +2x |
- #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list`+ nested = nested, |
||
| 295 | -+ | |||
| 177 | +2x |
- #' with 5 elements:+ extra_args = extra_args, |
||
| 296 | -+ | |||
| 178 | +2x |
- #' * `mod`: Cox regression models fitted by [survival::coxph()].+ show_labels = "hidden" |
||
| 297 | +179 |
- #' * `data`: The original data frame input.+ ) |
||
| 298 | +180 |
- #' * `control`: The original control input.+ } |
||
| 299 | +181 |
- #' * `vars`: The variables used in the model.+ |
||
| 300 | +182 |
- #' * `at`: Value of the covariate at which the effect should be estimated.+ #' Helper function to prepare ADLB for `count_abnormal_by_worst_grade()` |
||
| 301 | +183 |
#' |
||
| 302 | +184 |
- #' @note When using `fit_coxreg_univar` there should be two study arms.+ #' @description `r lifecycle::badge("stable")`
|
||
| 303 | +185 |
#' |
||
| 304 | +186 |
- #' @examples+ #' Helper function to prepare an ADLB data frame to be used as input in |
||
| 305 | +187 |
- #' # fit_coxreg_univar+ #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied: |
||
| 306 | +188 |
#' |
||
| 307 | +189 |
- #' ## Cox regression: arm + 1 covariate.+ #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits. |
||
| 308 | +190 |
- #' mod1 <- fit_coxreg_univar(+ #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only |
||
| 309 | +191 |
- #' variables = list(+ #' worst grades (in either direction) are included. |
||
| 310 | +192 |
- #' time = "time", event = "status", arm = "armcd",+ #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived |
||
| 311 | +193 |
- #' covariates = "covar1"+ #' and added to `adlb`: |
||
| 312 | +194 |
- #' ),+ #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when |
||
| 313 | +195 |
- #' data = dta_bladder,+ #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise. |
||
| 314 | +196 |
- #' control = control_coxreg(conf_level = 0.91)+ #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are |
||
| 315 | +197 |
- #' )+ #' replaced by their absolute values. |
||
| 316 | +198 |
- #'+ #' 4. Unused factor levels are dropped from `adlb` via [droplevels()]. |
||
| 317 | +199 |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ #' |
||
| 318 | +200 |
- #' mod2 <- fit_coxreg_univar(+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 319 | +201 |
- #' variables = list(+ #' @param atoxgr (`string`)\cr name of the analysis toxicity grade variable. This must be a `factor` |
||
| 320 | +202 |
- #' time = "time", event = "status", arm = "armcd",+ #' variable. |
||
| 321 | +203 |
- #' covariates = c("covar1", "covar2")
+ #' @param avisit (`string`)\cr name of the analysis visit variable. |
||
| 322 | +204 |
- #' ),+ #' @param worst_flag_low (`string`)\cr name of the worst low lab grade flag variable. This variable is |
||
| 323 | +205 |
- #' data = dta_bladder,+ #' set to `"Y"` when indicating records of worst low lab grades. |
||
| 324 | +206 |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ #' @param worst_flag_high (`string`)\cr name of the worst high lab grade flag variable. This variable is |
||
| 325 | +207 |
- #' )+ #' set to `"Y"` when indicating records of worst high lab grades. |
||
| 326 | +208 |
#' |
||
| 327 | +209 |
- #' ## Cox regression: arm + 1 covariate, stratified analysis.+ #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new |
||
| 328 | +210 |
- #' mod3 <- fit_coxreg_univar(+ #' variables: `GRADE_DIR` and `GRADE_ANL`. |
||
| 329 | +211 |
- #' variables = list(+ #' |
||
| 330 | +212 |
- #' time = "time", event = "status", arm = "armcd", strata = "covar2",+ #' @seealso [abnormal_by_worst_grade] |
||
| 331 | +213 |
- #' covariates = c("covar1")
+ #' |
||
| 332 | +214 |
- #' ),+ #' @examples |
||
| 333 | +215 |
- #' data = dta_bladder,+ #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>% |
||
| 334 | +216 |
- #' control = control_coxreg(conf_level = 0.91)+ #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>% |
||
| 335 | +217 |
- #' )+ #' head(10) |
||
| 336 | +218 |
#' |
||
| 337 | +219 |
- #' ## Cox regression: no arm, only covariates.+ #' @export |
||
| 338 | +220 |
- #' mod4 <- fit_coxreg_univar(+ h_adlb_abnormal_by_worst_grade <- function(adlb, |
||
| 339 | +221 |
- #' variables = list(+ atoxgr = "ATOXGR", |
||
| 340 | +222 |
- #' time = "time", event = "status",+ avisit = "AVISIT", |
||
| 341 | +223 |
- #' covariates = c("covar1", "covar2")
+ worst_flag_low = "WGRLOFL", |
||
| 342 | +224 |
- #' ),+ worst_flag_high = "WGRHIFL") {
|
||
| 343 | -+ | |||
| 225 | +1x |
- #' data = dta_bladder+ adlb %>% |
||
| 344 | -+ | |||
| 226 | +1x |
- #' )+ dplyr::filter( |
||
| 345 | -+ | |||
| 227 | +1x |
- #'+ !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
|
||
| 346 | -+ | |||
| 228 | +1x |
- #' @export+ .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y" |
||
| 347 | +229 |
- fit_coxreg_univar <- function(variables,+ ) %>% |
||
| 348 | -+ | |||
| 230 | +1x |
- data,+ dplyr::mutate( |
||
| 349 | -+ | |||
| 231 | +1x |
- at = list(),+ GRADE_DIR = factor( |
||
| 350 | -+ | |||
| 232 | +1x |
- control = control_coxreg()) {
+ dplyr::case_when( |
||
| 351 | -43x | +233 | +1x |
- checkmate::assert_list(variables, names = "named")+ .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
|
| 352 | -43x | +234 | +1x |
- has_arm <- "arm" %in% names(variables)+ .data[[atoxgr]] == "0" ~ "ZERO", |
| 353 | -43x | +235 | +1x |
- arm_name <- if (has_arm) "arm" else NULL+ .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
|
| 354 | +236 |
-
+ ), |
||
| 355 | -43x | +237 | +1x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ levels = c("LOW", "ZERO", "HIGH")
|
| 356 | +238 |
-
+ ), |
||
| 357 | -43x | -
- assert_df_with_variables(data, variables)- |
- ||
| 358 | -43x | -
- assert_list_of_variables(variables[c(arm_name, "event", "time")])- |
- ||
| 359 | -+ | 239 | +1x |
-
+ GRADE_ANL = forcats::fct_relevel( |
| 360 | -43x | +240 | +1x |
- if (!is.null(variables$strata)) {
+ forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"), |
| 361 | -4x | +241 | +1x |
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ c("0", "1", "2", "3", "4")
|
| 362 | +242 |
- }- |
- ||
| 363 | -42x | -
- if (has_arm) {
- |
- ||
| 364 | -36x | -
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ ) |
||
| 365 | +243 |
- }- |
- ||
| 366 | -41x | -
- vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE)- |
- ||
| 367 | -41x | -
- for (i in vars) {
- |
- ||
| 368 | -94x | -
- if (is.factor(data[[i]])) {
+ ) %>% |
||
| 369 | -82x | +244 | +1x |
- attr(data[[i]], "levels") <- levels(droplevels(data[[i]]))+ droplevels() |
| 370 | +245 |
- }+ } |
| 371 | +1 |
- }+ #' Analyze a pairwise Cox-PH model |
||
| 372 | -41x | +|||
| 2 | +
- forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction)+ #' |
|||
| 373 | -41x | +|||
| 3 | +
- mod <- lapply(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 374 | -41x | +|||
| 4 | +
- forms, function(x) {
+ #' |
|||
| 375 | -90x | +|||
| 5 | +
- survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties)+ #' The analyze function [coxph_pairwise()] creates a layout element to analyze a pairwise Cox-PH model. |
|||
| 376 | +6 |
- }+ #' |
||
| 377 | +7 |
- )+ #' This function can return statistics including p-value, hazard ratio (HR), and HR confidence intervals from both |
||
| 378 | -41x | +|||
| 8 | +
- structure(+ #' stratified and unstratified Cox-PH models. The variable(s) to be analyzed is specified via the `vars` argument and |
|||
| 379 | -41x | +|||
| 9 | +
- list(+ #' any stratification factors via the `strata` argument. |
|||
| 380 | -41x | +|||
| 10 | +
- mod = mod,+ #' |
|||
| 381 | -41x | +|||
| 11 | +
- data = data,+ #' @inheritParams argument_convention |
|||
| 382 | -41x | +|||
| 12 | +
- control = control,+ #' @inheritParams s_surv_time |
|||
| 383 | -41x | +|||
| 13 | +
- vars = variables,+ #' @param strata (`character` or `NULL`)\cr variable names indicating stratification factors. |
|||
| 384 | -41x | +|||
| 14 | +
- at = at+ #' @param strat `r lifecycle::badge("deprecated")` Please use the `strata` argument instead.
|
|||
| 385 | +15 |
- ),+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 386 | -41x | +|||
| 16 | +
- class = "coxreg.univar"+ #' [control_coxph()]. Some possible parameter options are: |
|||
| 387 | +17 |
- )+ #' * `pval_method` (`string`)\cr p-value method for testing the null hypothesis that hazard ratio = 1. Default |
||
| 388 | +18 |
- }+ #' method is `"log-rank"` which comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` |
||
| 389 | +19 |
-
+ #' (from [survival::coxph()]). |
||
| 390 | +20 |
- #' @describeIn fit_coxreg Fit a multivariate Cox regression model.+ #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`, |
||
| 391 | +21 |
- #'+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]. |
||
| 392 | +22 |
- #' @return+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
||
| 393 | +23 |
- #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 394 | +24 |
- #' with 4 elements:+ #' |
||
| 395 | +25 |
- #' * `mod`: Cox regression model fitted by [survival::coxph()].+ #' Options are: ``r shQuote(get_stats("coxph_pairwise"))``
|
||
| 396 | +26 |
- #' * `data`: The original data frame input.+ #' |
||
| 397 | +27 |
- #' * `control`: The original control input.+ #' @name survival_coxph_pairwise |
||
| 398 | +28 |
- #' * `vars`: The variables used in the model.+ #' @order 1 |
||
| 399 | +29 |
- #'+ NULL |
||
| 400 | +30 |
- #' @examples+ |
||
| 401 | +31 |
- #' # fit_coxreg_multivar+ #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR, and p-value of a Cox-PH model. |
||
| 402 | +32 |
#' |
||
| 403 | +33 |
- #' ## Cox regression: multivariate Cox regression.+ #' @return |
||
| 404 | +34 |
- #' multivar_model <- fit_coxreg_multivar(+ #' * `s_coxph_pairwise()` returns the statistics: |
||
| 405 | +35 |
- #' variables = list(+ #' * `pvalue`: p-value to test the null hypothesis that hazard ratio = 1. |
||
| 406 | +36 |
- #' time = "time", event = "status", arm = "armcd",+ #' * `hr`: Hazard ratio. |
||
| 407 | +37 |
- #' covariates = c("covar1", "covar2")
+ #' * `hr_ci`: Confidence interval for hazard ratio. |
||
| 408 | +38 |
- #' ),+ #' * `n_tot`: Total number of observations. |
||
| 409 | +39 |
- #' data = dta_bladder+ #' * `n_tot_events`: Total number of events. |
||
| 410 | +40 |
- #' )+ #' |
||
| 411 | +41 |
- #'+ #' @keywords internal |
||
| 412 | +42 |
- #' # Example without treatment arm.+ s_coxph_pairwise <- function(df, |
||
| 413 | +43 |
- #' multivar_covs_model <- fit_coxreg_multivar(+ .ref_group, |
||
| 414 | +44 |
- #' variables = list(+ .in_ref_col, |
||
| 415 | +45 |
- #' time = "time", event = "status",+ .var, |
||
| 416 | +46 |
- #' covariates = c("covar1", "covar2")
+ is_event, |
||
| 417 | +47 |
- #' ),+ strata = NULL, |
||
| 418 | +48 |
- #' data = dta_bladder+ strat = lifecycle::deprecated(), |
||
| 419 | +49 |
- #' )+ control = control_coxph()) {
|
||
| 420 | -+ | |||
| 50 | +92x |
- #'+ if (lifecycle::is_present(strat)) {
|
||
| 421 | -+ | |||
| 51 | +! |
- #' @export+ lifecycle::deprecate_warn("0.9.4", "s_coxph_pairwise(strat)", "s_coxph_pairwise(strata)")
|
||
| 422 | -+ | |||
| 52 | +! |
- fit_coxreg_multivar <- function(variables,+ strata <- strat |
||
| 423 | +53 |
- data,+ } |
||
| 424 | +54 |
- control = control_coxreg()) {
+
|
||
| 425 | -83x | +55 | +92x |
- checkmate::assert_list(variables, names = "named")+ checkmate::assert_string(.var) |
| 426 | -83x | +56 | +92x |
- has_arm <- "arm" %in% names(variables)+ checkmate::assert_numeric(df[[.var]]) |
| 427 | -83x | +57 | +92x |
- arm_name <- if (has_arm) "arm" else NULL+ checkmate::assert_logical(df[[is_event]]) |
| 428 | -+ | |||
| 58 | +92x |
-
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
||
| 429 | -83x | +59 | +92x |
- if (!is.null(variables$covariates)) {
+ pval_method <- control$pval_method |
| 430 | -21x | +60 | +92x |
- checkmate::assert_character(variables$covariates)+ ties <- control$ties |
| 431 | -+ | |||
| 61 | +92x |
- }+ conf_level <- control$conf_level |
||
| 432 | +62 | |||
| 433 | -83x | +63 | +92x |
- checkmate::assert_false(control$interaction)+ if (.in_ref_col) {
|
| 434 | -83x | +|||
| 64 | +! |
- assert_df_with_variables(data, variables)+ return( |
||
| 435 | -83x | +|||
| 65 | +! |
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ list( |
||
| 436 | -+ | |||
| 66 | +! |
-
+ pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
|
||
| 437 | -83x | +|||
| 67 | +! |
- if (!is.null(variables$strata)) {
+ hr = formatters::with_label("", "Hazard Ratio"),
|
||
| 438 | -3x | +|||
| 68 | +! |
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ hr_ci = formatters::with_label("", f_conf_level(conf_level)),
|
||
| 439 | -+ | |||
| 69 | +! |
- }+ n_tot = formatters::with_label("", "Total n"),
|
||
| 440 | -+ | |||
| 70 | +! |
-
+ n_tot_events = formatters::with_label("", "Total events")
|
||
| 441 | -82x | +|||
| 71 | +
- form <- h_coxreg_multivar_formula(variables)+ ) |
|||
| 442 | -82x | +|||
| 72 | +
- mod <- survival::coxph(+ ) |
|||
| 443 | -82x | +|||
| 73 | +
- formula = stats::as.formula(form),+ } |
|||
| 444 | -82x | +74 | +92x |
- data = data,+ data <- rbind(.ref_group, df) |
| 445 | -82x | +75 | +92x |
- ties = control$ties+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
| 446 | +76 |
- )+ |
||
| 447 | -82x | +77 | +92x |
- structure(+ df_cox <- data.frame( |
| 448 | -82x | +78 | +92x |
- list(+ tte = data[[.var]], |
| 449 | -82x | +79 | +92x |
- mod = mod,+ is_event = data[[is_event]], |
| 450 | -82x | +80 | +92x |
- data = data,+ arm = group+ |
+
| 81 | ++ |
+ ) |
||
| 451 | -82x | +82 | +92x |
- control = control,+ if (is.null(strata)) {
|
| 452 | -82x | +83 | +83x |
- vars = variables+ formula_cox <- survival::Surv(tte, is_event) ~ arm |
| 453 | +84 |
- ),+ } else {
|
||
| 454 | -82x | +85 | +9x |
- class = "coxreg.multivar"+ formula_cox <- stats::as.formula( |
| 455 | -+ | |||
| 86 | +9x |
- )+ paste0( |
||
| 456 | -+ | |||
| 87 | +9x |
- }+ "survival::Surv(tte, is_event) ~ arm + strata(",
|
||
| 457 | -+ | |||
| 88 | +9x |
-
+ paste(strata, collapse = ","), |
||
| 458 | +89 |
- #' Muffled `car::Anova`+ ")" |
||
| 459 | +90 |
- #'+ ) |
||
| 460 | +91 |
- #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when+ ) |
||
| 461 | -+ | |||
| 92 | +9x |
- #' present, this function deliberately muffles this message.+ df_cox <- cbind(df_cox, data[strata]) |
||
| 462 | +93 |
- #'+ } |
||
| 463 | -+ | |||
| 94 | +92x |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].+ cox_fit <- survival::coxph( |
||
| 464 | -+ | |||
| 95 | +92x |
- #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ formula = formula_cox, |
||
| 465 | -+ | |||
| 96 | +92x |
- #'+ data = df_cox, |
||
| 466 | -+ | |||
| 97 | +92x |
- #' @return The output of [car::Anova()], with convergence message muffled.+ ties = ties |
||
| 467 | +98 |
- #'+ ) |
||
| 468 | -+ | |||
| 99 | +92x |
- #' @keywords internal+ sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE) |
||
| 469 | -+ | |||
| 100 | +92x |
- muffled_car_anova <- function(mod, test_statistic) {
+ orginal_survdiff <- survival::survdiff( |
||
| 470 | -219x | +101 | +92x |
- tryCatch(+ formula_cox, |
| 471 | -219x | +102 | +92x |
- withCallingHandlers(+ data = df_cox |
| 472 | -219x | +|||
| 103 | +
- expr = {
+ ) |
|||
| 473 | -219x | +104 | +92x |
- car::Anova(+ log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ |
+
| 105 | ++ | + | ||
| 474 | -219x | +106 | +92x |
- mod,+ pval <- switch(pval_method, |
| 475 | -219x | +107 | +92x |
- test.statistic = test_statistic,+ "wald" = sum_cox$waldtest["pvalue"], |
| 476 | -219x | +108 | +92x |
- type = "III"+ "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff() |
| 477 | -+ | |||
| 109 | +92x |
- )+ "likelihood" = sum_cox$logtest["pvalue"] |
||
| 478 | +110 |
- },+ ) |
||
| 479 | -219x | +111 | +92x |
- message = function(m) invokeRestart("muffleMessage"),
+ list( |
| 480 | -219x | +112 | +92x |
- error = function(e) {
+ pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
|
| 481 | -1x | +113 | +92x |
- stop(paste(+ hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"), |
| 482 | -1x | +114 | +92x |
- "the model seems to have convergence problems, please try to change",+ hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)), |
| 483 | -1x | +115 | +92x |
- "the configuration of covariates or strata variables, e.g.",+ n_tot = formatters::with_label(sum_cox$n, "Total n"), |
| 484 | -1x | +116 | +92x |
- "- original error:", e+ n_tot_events = formatters::with_label(sum_cox$nevent, "Total events") |
| 485 | +117 |
- ))+ ) |
||
| 486 | +118 |
- }+ } |
||
| 487 | +119 |
- )+ |
||
| 488 | +120 |
- )+ #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`. |
||
| 489 | +121 |
- }+ #' |
| 1 | +122 |
- #' Helper functions for accessing information from `rtables`+ #' @return |
||
| 2 | +123 |
- #'+ #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 3 | +124 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 | +125 |
- #'+ #' @keywords internal |
||
| 5 | +126 |
- #' These are a couple of functions that help with accessing the data in `rtables` objects.+ a_coxph_pairwise <- make_afun( |
||
| 6 | +127 |
- #' Currently these work for occurrence tables, which are defined as having a count as the first+ s_coxph_pairwise, |
||
| 7 | +128 |
- #' element and a fraction as the second element in each cell.+ .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L), |
||
| 8 | +129 |
- #'+ .formats = c( |
||
| 9 | +130 |
- #' @seealso [prune_occurrences] for usage of these functions.+ pvalue = "x.xxxx | (<0.0001)", |
||
| 10 | +131 |
- #'+ hr = "xx.xx", |
||
| 11 | +132 |
- #' @name rtables_access+ hr_ci = "(xx.xx, xx.xx)", |
||
| 12 | +133 |
- NULL+ n_tot = "xx.xx", |
||
| 13 | +134 |
-
+ n_tot_events = "xx.xx" |
||
| 14 | +135 |
- #' @describeIn rtables_access Helper function to extract the first values from each content+ ) |
||
| 15 | +136 |
- #' cell and from specified columns in a `TableRow`. Defaults to all columns.+ ) |
||
| 16 | +137 |
- #'+ |
||
| 17 | +138 |
- #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table.+ #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments |
||
| 18 | +139 |
- #' @param col_names (`character`)\cr the names of the columns to extract from.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 19 | +140 |
- #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided,+ #' |
||
| 20 | +141 |
- #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single+ #' @return |
||
| 21 | +142 |
- #' column split.+ #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions, |
||
| 22 | +143 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 23 | +144 |
- #' @return+ #' the statistics from `s_coxph_pairwise()` to the table layout. |
||
| 24 | +145 |
- #' * `h_row_first_values()` returns a `vector` of numeric values.+ #' |
||
| 25 | +146 |
- #'+ #' @examples |
||
| 26 | +147 |
- #' @examples+ #' library(dplyr) |
||
| 27 | +148 |
- #' tbl <- basic_table() %>%+ #' |
||
| 28 | +149 |
- #' split_cols_by("ARM") %>%
+ #' adtte_f <- tern_ex_adtte %>% |
||
| 29 | +150 |
- #' split_rows_by("RACE") %>%
+ #' filter(PARAMCD == "OS") %>% |
||
| 30 | +151 |
- #' analyze("AGE", function(x) {
+ #' mutate(is_event = CNSR == 0) |
||
| 31 | +152 |
- #' list(+ #' |
||
| 32 | +153 |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"),+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 33 | +154 |
- #' "n" = length(x),+ #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B") |
||
| 34 | +155 |
- #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)")+ #' |
||
| 35 | +156 |
- #' )+ #' basic_table() %>% |
||
| 36 | +157 |
- #' }) %>%+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 37 | +158 |
- #' build_table(tern_ex_adsl) %>%+ #' add_colcounts() %>% |
||
| 38 | +159 |
- #' prune_table()+ #' coxph_pairwise( |
||
| 39 | +160 |
- #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]]+ #' vars = "AVAL", |
||
| 40 | +161 |
- #' result <- max(h_row_first_values(tree_row_elem))+ #' is_event = "is_event", |
||
| 41 | +162 |
- #' result+ #' var_labels = "Unstratified Analysis" |
||
| 42 | +163 |
- #'+ #' ) %>% |
||
| 43 | +164 |
- #' @export+ #' build_table(df = adtte_f) |
||
| 44 | +165 |
- h_row_first_values <- function(table_row,+ #' |
||
| 45 | +166 |
- col_names = NULL,+ #' basic_table() %>% |
||
| 46 | +167 |
- col_indices = NULL) {
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 47 | -745x | +|||
| 168 | +
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ #' add_colcounts() %>% |
|||
| 48 | -744x | +|||
| 169 | +
- checkmate::assert_integerish(col_indices)+ #' coxph_pairwise( |
|||
| 49 | -744x | +|||
| 170 | +
- checkmate::assert_subset(col_indices, seq_len(ncol(table_row)))+ #' vars = "AVAL", |
|||
| 50 | +171 |
-
+ #' is_event = "is_event", |
||
| 51 | +172 |
- # Main values are extracted+ #' var_labels = "Stratified Analysis", |
||
| 52 | -744x | +|||
| 173 | +
- row_vals <- row_values(table_row)[col_indices]+ #' strata = "SEX", |
|||
| 53 | +174 |
-
+ #' control = control_coxph(pval_method = "wald") |
||
| 54 | +175 |
- # Main return+ #' ) %>% |
||
| 55 | -744x | +|||
| 176 | +
- vapply(row_vals, function(rv) {
+ #' build_table(df = adtte_f) |
|||
| 56 | -2096x | +|||
| 177 | +
- if (is.null(rv)) {
+ #' |
|||
| 57 | -744x | +|||
| 178 | +
- NA_real_+ #' @export |
|||
| 58 | +179 |
- } else {
+ #' @order 2 |
||
| 59 | -2090x | +|||
| 180 | +
- rv[1L]+ coxph_pairwise <- function(lyt, |
|||
| 60 | +181 |
- }+ vars, |
||
| 61 | -744x | +|||
| 182 | +
- }, FUN.VALUE = numeric(1))+ strata = NULL, |
|||
| 62 | +183 |
- }+ control = control_coxph(), |
||
| 63 | +184 |
-
+ na_str = default_na_str(), |
||
| 64 | +185 |
- #' @describeIn rtables_access Helper function that extracts row values and checks if they are+ nested = TRUE, |
||
| 65 | +186 |
- #' convertible to integers (`integerish` values).+ ..., |
||
| 66 | +187 |
- #'+ var_labels = "CoxPH", |
||
| 67 | +188 |
- #' @return+ show_labels = "visible", |
||
| 68 | +189 |
- #' * `h_row_counts()` returns a `vector` of numeric values.+ table_names = vars, |
||
| 69 | +190 |
- #'+ .stats = c("pvalue", "hr", "hr_ci"),
|
||
| 70 | +191 |
- #' @examples+ .formats = NULL, |
||
| 71 | +192 |
- #' # Row counts (integer values)+ .labels = NULL, |
||
| 72 | +193 |
- #' # h_row_counts(tree_row_elem) # Fails because there are no integers+ .indent_mods = NULL) {
|
||
| 73 | -+ | |||
| 194 | +5x |
- #' # Using values with integers+ extra_args <- list(strata = strata, control = control, ...) |
||
| 74 | +195 |
- #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]]+ |
||
| 75 | -+ | |||
| 196 | +5x |
- #' result <- h_row_counts(tree_row_elem)+ afun <- make_afun( |
||
| 76 | -+ | |||
| 197 | +5x |
- #' # result+ a_coxph_pairwise, |
||
| 77 | -+ | |||
| 198 | +5x |
- #'+ .stats = .stats, |
||
| 78 | -+ | |||
| 199 | +5x |
- #' @export+ .formats = .formats, |
||
| 79 | -+ | |||
| 200 | +5x |
- h_row_counts <- function(table_row,+ .labels = .labels, |
||
| 80 | -+ | |||
| 201 | +5x |
- col_names = NULL,+ .indent_mods = .indent_mods |
||
| 81 | +202 |
- col_indices = NULL) {
+ ) |
||
| 82 | -741x | +203 | +5x |
- counts <- h_row_first_values(table_row, col_names, col_indices)+ analyze( |
| 83 | -741x | +204 | +5x |
- checkmate::assert_integerish(counts)+ lyt, |
| 84 | -741x | +205 | +5x |
- counts+ vars,+ |
+
| 206 | +5x | +
+ var_labels = var_labels,+ |
+ ||
| 207 | +5x | +
+ show_labels = show_labels,+ |
+ ||
| 208 | +5x | +
+ table_names = table_names,+ |
+ ||
| 209 | +5x | +
+ afun = afun,+ |
+ ||
| 210 | +5x | +
+ na_str = na_str,+ |
+ ||
| 211 | +5x | +
+ nested = nested,+ |
+ ||
| 212 | +5x | +
+ extra_args = extra_args |
||
| 85 | +213 | ++ |
+ )+ |
+ |
| 214 |
} |
| 86 | +1 |
-
+ #' Count specific values |
||
| 87 | +2 |
- #' @describeIn rtables_access Helper function to extract fractions from specified columns in a `TableRow`.+ #' |
||
| 88 | +3 |
- #' More specifically it extracts the second values from each content cell and checks it is a fraction.+ #' @description `r lifecycle::badge("stable")`
|
||
| 89 | +4 |
#' |
||
| 90 | +5 |
- #' @return+ #' The analyze function [count_values()] creates a layout element to calculate counts of specific values within a |
||
| 91 | +6 |
- #' * `h_row_fractions()` returns a `vector` of proportions.+ #' variable of interest. |
||
| 92 | +7 |
#' |
||
| 93 | +8 |
- #' @examples+ #' This function analyzes one or more variables of interest supplied as a vector to `vars`. Values to |
||
| 94 | +9 |
- #' # Row fractions+ #' count for variable(s) in `vars` can be given as a vector via the `values` argument. One row of |
||
| 95 | +10 |
- #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]]+ #' counts will be generated for each variable. |
||
| 96 | +11 |
- #' h_row_fractions(tree_row_elem)+ #' |
||
| 97 | +12 |
- #'+ #' @inheritParams argument_convention |
||
| 98 | +13 |
- #' @export+ #' @param values (`character`)\cr specific values that should be counted. |
||
| 99 | +14 |
- h_row_fractions <- function(table_row,+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 100 | +15 |
- col_names = NULL,+ #' |
||
| 101 | +16 |
- col_indices = NULL) {
+ #' Options are: ``r shQuote(get_stats("count_values"))``
|
||
| 102 | -250x | +|||
| 17 | +
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ #' |
|||
| 103 | -250x | +|||
| 18 | +
- row_vals <- row_values(table_row)[col_indices]+ #' @note |
|||
| 104 | -250x | +|||
| 19 | +
- fractions <- sapply(row_vals, "[", 2L)+ #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x` |
|||
| 105 | -250x | +|||
| 20 | +
- checkmate::assert_numeric(fractions, lower = 0, upper = 1)+ #' and fails otherwise. |
|||
| 106 | -250x | +|||
| 21 | +
- fractions+ #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`, |
|||
| 107 | +22 |
- }+ #' otherwise they are hidden. |
||
| 108 | +23 |
-
+ #' |
||
| 109 | +24 |
- #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table.+ #' @name count_values |
||
| 110 | +25 |
- #'+ #' @order 1 |
||
| 111 | +26 |
- #' @param table (`VTableNodeInfo`)\cr an occurrence table or row.+ NULL |
||
| 112 | +27 |
- #'+ |
||
| 113 | +28 |
- #' @return+ #' @describeIn count_values S3 generic function to count values. |
||
| 114 | +29 |
- #' * `h_col_counts()` returns a `vector` of column counts.+ #' |
||
| 115 | +30 |
- #'+ #' @inheritParams s_summary.logical |
||
| 116 | +31 |
- #' @export+ #' |
||
| 117 | +32 |
- h_col_counts <- function(table,+ #' @return |
||
| 118 | +33 |
- col_names = NULL,+ #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable. |
||
| 119 | +34 |
- col_indices = NULL) {
+ #' |
||
| 120 | -307x | +|||
| 35 | +
- col_indices <- check_names_indices(table, col_names, col_indices)+ #' @export |
|||
| 121 | -307x | +|||
| 36 | +
- counts <- col_counts(table)[col_indices]+ s_count_values <- function(x, |
|||
| 122 | -307x | +|||
| 37 | +
- stats::setNames(counts, col_names)+ values, |
|||
| 123 | +38 |
- }+ na.rm = TRUE, # nolint |
||
| 124 | +39 |
-
+ .N_col, # nolint |
||
| 125 | +40 |
- #' @describeIn rtables_access Helper function to get first row of content table of current table.+ .N_row, # nolint |
||
| 126 | +41 |
- #'+ denom = c("n", "N_col", "N_row")) {
+ |
+ ||
| 42 | +189x | +
+ UseMethod("s_count_values", x)
|
||
| 127 | +43 |
- #' @return+ } |
||
| 128 | +44 |
- #' * `h_content_first_row()` returns a row from an `rtables` table.+ |
||
| 129 | +45 |
- #'+ #' @describeIn count_values Method for `character` class. |
||
| 130 | +46 |
- #' @export+ #' |
||
| 131 | +47 |
- h_content_first_row <- function(table) {
+ #' @method s_count_values character |
||
| 132 | -27x | +|||
| 48 | +
- ct <- content_table(table)+ #' |
|||
| 133 | -27x | +|||
| 49 | +
- tree_children(ct)[[1]]+ #' @examples |
|||
| 134 | +50 |
- }+ #' # `s_count_values.character` |
||
| 135 | +51 |
-
+ #' s_count_values(x = c("a", "b", "a"), values = "a")
|
||
| 136 | +52 |
- #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree.+ #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
|
||
| 137 | +53 |
#' |
||
| 138 | +54 |
- #' @return+ #' @export |
||
| 139 | +55 |
- #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf.+ s_count_values.character <- function(x, |
||
| 140 | +56 |
- #'+ values = "Y", |
||
| 141 | +57 |
- #' @keywords internal+ na.rm = TRUE, # nolint |
||
| 142 | +58 |
- is_leaf_table <- function(table) {
+ ...) {
|
||
| 143 | -168x | +59 | +187x |
- children <- tree_children(table)+ checkmate::assert_character(values)+ |
+
| 60 | ++ | + | ||
| 144 | -168x | +61 | +187x |
- child_classes <- unique(sapply(children, class))+ if (na.rm) {
|
| 145 | -168x | +62 | +186x |
- identical(child_classes, "ElementaryTable")+ x <- x[!is.na(x)] |
| 146 | +63 |
- }+ } |
||
| 147 | +64 | |||
| 148 | -+ | |||
| 65 | +187x |
- #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices.+ is_in_values <- x %in% values |
||
| 149 | +66 |
- #'+ |
||
| 150 | -+ | |||
| 67 | +187x |
- #' @return+ s_summary(is_in_values, ...) |
||
| 151 | +68 |
- #' * `check_names_indices` returns column indices.+ } |
||
| 152 | +69 |
- #'+ |
||
| 153 | +70 |
- #' @keywords internal+ #' @describeIn count_values Method for `factor` class. This makes an automatic |
||
| 154 | +71 |
- check_names_indices <- function(table_row,+ #' conversion to `character` and then forwards to the method for characters. |
||
| 155 | +72 |
- col_names = NULL,+ #' |
||
| 156 | +73 |
- col_indices = NULL) {
+ #' @method s_count_values factor |
||
| 157 | -1302x | +|||
| 74 | +
- if (!is.null(col_names)) {
+ #' |
|||
| 158 | -1256x | +|||
| 75 | +
- if (!is.null(col_indices)) {
+ #' @examples |
|||
| 159 | -1x | +|||
| 76 | +
- stop(+ #' # `s_count_values.factor` |
|||
| 160 | -1x | +|||
| 77 | +
- "Inserted both col_names and col_indices when selecting row values. ",+ #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
|
|||
| 161 | -1x | +|||
| 78 | +
- "Please choose one."+ #' |
|||
| 162 | +79 |
- )+ #' @export |
||
| 163 | +80 |
- }+ s_count_values.factor <- function(x, |
||
| 164 | -1255x | +|||
| 81 | +
- col_indices <- h_col_indices(table_row, col_names)+ values = "Y", |
|||
| 165 | +82 |
- }+ ...) {
|
||
| 166 | -1301x | +83 | +3x |
- if (is.null(col_indices)) {
+ s_count_values(as.character(x), values = as.character(values), ...) |
| 167 | -39x | +|||
| 84 | +
- ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row))+ } |
|||
| 168 | -39x | +|||
| 85 | +
- col_indices <- seq_len(ll)+ |
|||
| 169 | +86 |
- }+ #' @describeIn count_values Method for `logical` class. |
||
| 170 | +87 |
-
+ #' |
||
| 171 | -1301x | +|||
| 88 | +
- return(col_indices)+ #' @method s_count_values logical |
|||
| 172 | +89 |
- }+ #' |
| 1 | +90 |
- #' Count number of patients+ #' @examples |
||
| 2 | +91 |
- #'+ #' # `s_count_values.logical` |
||
| 3 | +92 |
- #' @description `r lifecycle::badge("stable")`
+ #' s_count_values(x = c(TRUE, FALSE, TRUE)) |
||
| 4 | +93 |
#' |
||
| 5 | +94 |
- #' The analyze function [analyze_num_patients()] creates a layout element to count total numbers of unique or+ #' @export |
||
| 6 | +95 |
- #' non-unique patients. The primary analysis variable `vars` is used to uniquely identify patients.+ s_count_values.logical <- function(x, values = TRUE, ...) {
|
||
| 7 | -+ | |||
| 96 | +3x |
- #'+ checkmate::assert_logical(values)+ |
+ ||
| 97 | +3x | +
+ s_count_values(as.character(x), values = as.character(values), ...) |
||
| 8 | +98 |
- #' The `count_by` variable can be used to identify non-unique patients such that the number of patients with a unique+ } |
||
| 9 | +99 |
- #' combination of values in `vars` and `count_by` will be returned instead as the `nonunique` statistic. The `required`+ |
||
| 10 | +100 |
- #' variable can be used to specify a variable required to be non-missing for the record to be included in the counts.+ #' @describeIn count_values Formatted analysis function which is used as `afun` |
||
| 11 | +101 |
- #'+ #' in `count_values()`. |
||
| 12 | +102 |
- #' The summarize function [summarize_num_patients()] performs the same function as [analyze_num_patients()] except it+ #' |
||
| 13 | +103 |
- #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of+ #' @return |
||
| 14 | +104 |
- #' the latest row split or the root of the table if no row splits have occurred.+ #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 15 | +105 |
#' |
||
| 16 | +106 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 17 | +107 |
- #' @param required (`character` or `NULL`)\cr name of a variable that is required to be non-missing.+ #' # `a_count_values` |
||
| 18 | +108 |
- #' @param count_by (`character` or `NULL`)\cr name of a variable to be combined with `vars` when counting+ #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
|
||
| 19 | +109 |
- #' `nonunique` records.+ #' |
||
| 20 | +110 |
- #' @param unique_count_suffix (`flag`)\cr whether the `"(n)"` suffix should be added to `unique_count` labels.+ #' @export |
||
| 21 | +111 |
- #' Defaults to `TRUE`.+ a_count_values <- make_afun( |
||
| 22 | +112 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ s_count_values, |
||
| 23 | +113 |
- #'+ .formats = c(count_fraction = "xx (xx.xx%)", count = "xx") |
||
| 24 | +114 |
- #' Options are: ``r shQuote(get_stats("summarize_num_patients"))``
+ ) |
||
| 25 | +115 |
- #'+ |
||
| 26 | +116 |
- #' @name summarize_num_patients+ #' @describeIn count_values Layout-creating function which can take statistics function arguments |
||
| 27 | +117 |
- #' @order 1+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 28 | +118 |
- NULL+ #' |
||
| 29 | +119 |
-
+ #' @return |
||
| 30 | +120 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of+ #' * `count_values()` returns a layout object suitable for passing to further layouting functions, |
||
| 31 | +121 |
- #' unique patients, the corresponding percentage taken with respect to the+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 32 | +122 |
- #' total number of patients, and the number of non-unique patients.+ #' the statistics from `s_count_values()` to the table layout. |
||
| 33 | +123 |
#' |
||
| 34 | +124 |
- #' @param x (`character` or `factor`)\cr vector of patient IDs.+ #' @examples |
||
| 35 | +125 |
- #'+ #' # `count_values` |
||
| 36 | +126 |
- #' @return+ #' basic_table() %>% |
||
| 37 | +127 |
- #' * `s_num_patients()` returns a named `list` of 3 statistics:+ #' count_values("Species", values = "setosa") %>%
|
||
| 38 | +128 |
- #' * `unique`: Vector of counts and percentages.+ #' build_table(iris) |
||
| 39 | +129 |
- #' * `nonunique`: Vector of counts.+ #' |
||
| 40 | +130 |
- #' * `unique_count`: Counts.+ #' @export |
||
| 41 | +131 |
- #'+ #' @order 2 |
||
| 42 | +132 |
- #' @examples+ count_values <- function(lyt, |
||
| 43 | +133 |
- #' # Use the statistics function to count number of unique and nonunique patients.+ vars, |
||
| 44 | +134 |
- #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L)+ values, |
||
| 45 | +135 |
- #' s_num_patients(+ na_str = default_na_str(), |
||
| 46 | +136 |
- #' x = as.character(c(1, 1, 1, 2, 4, NA)),+ nested = TRUE, |
||
| 47 | +137 |
- #' labelstr = "",+ ..., |
||
| 48 | +138 |
- #' .N_col = 6L,+ table_names = vars, |
||
| 49 | +139 |
- #' count_by = c(1, 1, 2, 1, 1, 1)+ .stats = "count_fraction", |
||
| 50 | +140 |
- #' )+ .formats = NULL, |
||
| 51 | +141 |
- #'+ .labels = c(count_fraction = paste(values, collapse = ", ")), |
||
| 52 | +142 |
- #' @export+ .indent_mods = NULL) {
|
||
| 53 | -+ | |||
| 143 | +3x |
- s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
+ extra_args <- list(values = values, ...) |
||
| 54 | +144 | |||
| 55 | -146x | +145 | +3x |
- checkmate::assert_string(labelstr)+ afun <- make_afun( |
| 56 | -146x | +146 | +3x |
- checkmate::assert_count(.N_col)+ a_count_values, |
| 57 | -146x | +147 | +3x |
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ .stats = .stats, |
| 58 | -146x | -
- checkmate::assert_flag(unique_count_suffix)- |
- ||
| 59 | -+ | 148 | +3x |
-
+ .formats = .formats, |
| 60 | -146x | +149 | +3x |
- count1 <- n_available(unique(x))+ .labels = .labels, |
| 61 | -146x | +150 | +3x |
- count2 <- n_available(x)+ .indent_mods = .indent_mods |
| 62 | +151 |
-
+ ) |
||
| 63 | -146x | +152 | +3x |
- if (!is.null(count_by)) {
+ analyze( |
| 64 | -16x | +153 | +3x |
- checkmate::assert_vector(count_by, len = length(x))+ lyt, |
| 65 | -16x | -
- count2 <- n_available(unique(interaction(x, count_by)))- |
- ||
| 66 | -+ | 154 | +3x |
- }+ vars, |
| 67 | -+ | |||
| 155 | +3x |
-
+ afun = afun, |
||
| 68 | -146x | +156 | +3x |
- out <- list(+ na_str = na_str, |
| 69 | -146x | +157 | +3x |
- unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr),+ nested = nested, |
| 70 | -146x | +158 | +3x |
- nonunique = formatters::with_label(count2, labelstr),+ extra_args = extra_args, |
| 71 | -146x | +159 | +3x |
- unique_count = formatters::with_label(+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 72 | -146x | +160 | +3x |
- count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr)+ table_names = table_names |
| 73 | +161 |
- )+ ) |
||
| 74 | +162 |
- )+ } |
| 75 | +1 |
-
+ #' Helper function for tabulation of a single biomarker result |
||
| 76 | -146x | +|||
| 2 | +
- out+ #' |
|||
| 77 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 78 | +4 |
-
+ #' |
||
| 79 | +5 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients+ #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples. |
||
| 80 | +6 |
- #' in a column (variable), the corresponding percentage taken with respect to the total number of+ #' This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 81 | +7 |
- #' patients, and the number of non-unique patients in the column.+ #' |
||
| 82 | +8 |
- #'+ #' @inheritParams argument_convention |
||
| 83 | +9 |
- #' @return+ #' @param df (`data.frame`)\cr results for a single biomarker. |
||
| 84 | +10 |
- #' * `s_num_patients_content()` returns the same values as `s_num_patients()`.+ #' @param afuns (named `list` of `function`)\cr analysis functions. |
||
| 85 | +11 |
- #'+ #' @param colvars (named `list`)\cr named list with elements `vars` (variables to tabulate) and `labels` (their labels). |
||
| 86 | +12 |
- #' @examples+ #' |
||
| 87 | +13 |
- #' # Count number of unique and non-unique patients.+ #' @return An `rtables` table object with statistics in columns. |
||
| 88 | +14 |
#' |
||
| 89 | +15 |
- #' df <- data.frame(+ #' @export |
||
| 90 | +16 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ h_tab_one_biomarker <- function(df, |
||
| 91 | +17 |
- #' EVENT = as.character(c(10, 15, 10, 17, 8))+ afuns, |
||
| 92 | +18 |
- #' )+ colvars, |
||
| 93 | +19 |
- #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID")+ na_str = default_na_str(), |
||
| 94 | +20 |
- #'+ .indent_mods = 0L, |
||
| 95 | +21 |
- #' df_by_event <- data.frame(+ ...) {
|
||
| 96 | -+ | |||
| 22 | +18x |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ extra_args <- list(...) |
||
| 97 | +23 |
- #' EVENT = c(10, 15, 10, 17, 8)+ |
||
| 98 | +24 |
- #' )+ # Create "ci" column from "lcl" and "ucl" |
||
| 99 | -+ | |||
| 25 | +18x |
- #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT")+ df$ci <- combine_vectors(df$lcl, df$ucl) |
||
| 100 | +26 |
- #'+ + |
+ ||
| 27 | +18x | +
+ lyt <- basic_table() |
||
| 101 | +28 |
- #' @export+ |
||
| 102 | +29 |
- s_num_patients_content <- function(df,+ # Row split by row type - only keep the content rows here.+ |
+ ||
| 30 | +18x | +
+ lyt <- split_rows_by(+ |
+ ||
| 31 | +18x | +
+ lyt = lyt,+ |
+ ||
| 32 | +18x | +
+ var = "row_type",+ |
+ ||
| 33 | +18x | +
+ split_fun = keep_split_levels("content"),
+ |
+ ||
| 34 | +18x | +
+ nested = FALSE |
||
| 103 | +35 |
- labelstr = "",+ ) |
||
| 104 | +36 |
- .N_col, # nolint+ |
||
| 105 | +37 |
- .var,+ # Summarize rows with all patients.+ |
+ ||
| 38 | +18x | +
+ lyt <- summarize_row_groups(+ |
+ ||
| 39 | +18x | +
+ lyt = lyt,+ |
+ ||
| 40 | +18x | +
+ var = "var_label",+ |
+ ||
| 41 | +18x | +
+ cfun = afuns,+ |
+ ||
| 42 | +18x | +
+ na_str = na_str,+ |
+ ||
| 43 | +18x | +
+ indent_mod = .indent_mods,+ |
+ ||
| 44 | +18x | +
+ extra_args = extra_args |
||
| 106 | +45 |
- required = NULL,+ ) |
||
| 107 | +46 |
- count_by = NULL,+ |
||
| 108 | +47 |
- unique_count_suffix = TRUE) {
+ # Split cols by the multiple variables to populate into columns. |
||
| 109 | -56x | +48 | +18x |
- checkmate::assert_string(.var)+ lyt <- split_cols_by_multivar( |
| 110 | -56x | +49 | +18x |
- checkmate::assert_data_frame(df)+ lyt = lyt, |
| 111 | -56x | +50 | +18x |
- if (is.null(count_by)) {
+ vars = colvars$vars, |
| 112 | -53x | +51 | +18x |
- assert_df_with_variables(df, list(id = .var))+ varlabels = colvars$labels |
| 113 | +52 |
- } else {
+ )+ |
+ ||
| 53 | ++ | + + | +||
| 54 | ++ |
+ # If there is any subgroup variables, we extend the layout accordingly. |
||
| 114 | -3x | +55 | +18x |
- assert_df_with_variables(df, list(id = .var, count_by = count_by))+ if ("analysis" %in% df$row_type) {
|
| 115 | +56 |
- }+ # Now only continue with the subgroup rows. |
||
| 116 | -56x | +57 | +10x |
- if (!is.null(required)) {
+ lyt <- split_rows_by( |
| 117 | -! | +|||
| 58 | +10x |
- checkmate::assert_string(required)+ lyt = lyt, |
||
| 118 | -! | +|||
| 59 | +10x |
- assert_df_with_variables(df, list(required = required))+ var = "row_type", |
||
| 119 | -! | +|||
| 60 | +10x |
- df <- df[!is.na(df[[required]]), , drop = FALSE]+ split_fun = keep_split_levels("analysis"),
+ |
+ ||
| 61 | +10x | +
+ nested = FALSE,+ |
+ ||
| 62 | +10x | +
+ child_labels = "hidden" |
||
| 120 | +63 |
- }+ ) |
||
| 121 | +64 | |||
| 65 | ++ |
+ # Split by the subgroup variable.+ |
+ ||
| 122 | -56x | +66 | +10x |
- x <- df[[.var]]+ lyt <- split_rows_by( |
| 123 | -56x | +67 | +10x |
- y <- if (is.null(count_by)) NULL else df[[count_by]]+ lyt = lyt,+ |
+
| 68 | +10x | +
+ var = "var",+ |
+ ||
| 69 | +10x | +
+ labels_var = "var_label",+ |
+ ||
| 70 | +10x | +
+ nested = TRUE,+ |
+ ||
| 71 | +10x | +
+ child_labels = "visible",+ |
+ ||
| 72 | +10x | +
+ indent_mod = .indent_mods * 2 |
||
| 124 | +73 | ++ |
+ )+ |
+ |
| 74 | ||||
| 75 | ++ |
+ # Then analyze colvars for each subgroup.+ |
+ ||
| 125 | -56x | +76 | +10x |
- s_num_patients(+ lyt <- summarize_row_groups( |
| 126 | -56x | +77 | +10x |
- x = x,+ lyt = lyt, |
| 127 | -56x | +78 | +10x |
- labelstr = labelstr,+ cfun = afuns, |
| 128 | -56x | +79 | +10x |
- .N_col = .N_col,+ var = "subgroup", |
| 129 | -56x | +80 | +10x |
- count_by = y,+ na_str = na_str, |
| 130 | -56x | +81 | +10x |
- unique_count_suffix = unique_count_suffix+ extra_args = extra_args |
| 131 | +82 |
- )+ ) |
||
| 132 | +83 | ++ |
+ }+ |
+ |
| 84 | +18x | +
+ build_table(lyt, df = df)+ |
+ ||
| 85 |
} |
| 133 | +1 |
-
+ #' Control function for subgroup treatment effect pattern (STEP) calculations |
||
| 134 | +2 |
- c_num_patients <- make_afun(+ #' |
||
| 135 | +3 |
- s_num_patients_content,+ #' @description `r lifecycle::badge("stable")`
|
||
| 136 | +4 |
- .stats = c("unique", "nonunique", "unique_count"),
+ #' |
||
| 137 | +5 |
- .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx")+ #' This is an auxiliary function for controlling arguments for STEP calculations. |
||
| 138 | +6 |
- )+ #' |
||
| 139 | +7 |
-
+ #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which |
||
| 140 | +8 |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ #' could be used to infer `bandwidth`, see below. |
||
| 141 | +9 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to |
||
| 142 | +10 |
- #'+ #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data |
||
| 143 | +11 |
- #' @return+ #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly |
||
| 144 | +12 |
- #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions,+ #' distributed. |
||
| 145 | +13 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @param bandwidth (`numeric(1)` or `NULL`)\cr indicating the bandwidth of each window. |
||
| 146 | +14 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ #' Depending on the argument `use_percentile`, it can be either the length of actual-value |
||
| 147 | +15 |
- #'+ #' windows on the real biomarker scale, or percentage windows. |
||
| 148 | +16 |
- #' @examples+ #' If `use_percentile = TRUE`, it should be a number between 0 and 1. |
||
| 149 | +17 |
- #' # summarize_num_patients+ #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted. |
||
| 150 | +18 |
- #' tbl <- basic_table() %>%+ #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker` |
||
| 151 | +19 |
- #' split_cols_by("ARM") %>%
+ #' variable for actual-value windows. |
||
| 152 | +20 |
- #' split_rows_by("SEX") %>%
+ #' @param degree (`integer(1)`)\cr the degree of polynomial function of the biomarker as an interaction term |
||
| 153 | +21 |
- #' summarize_num_patients("USUBJID", .stats = "unique_count") %>%
+ #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable |
||
| 154 | +22 |
- #' build_table(df)+ #' is not included in the model fitted in each biomarker window. |
||
| 155 | +23 |
- #'+ #' @param num_points (`integer(1)`)\cr the number of points at which the hazard ratios are estimated. The |
||
| 156 | +24 |
- #' tbl+ #' smallest number is 2. |
||
| 157 | +25 |
#' |
||
| 158 | +26 |
- #' @export+ #' @return A list of components with the same names as the arguments, except `biomarker` which is |
||
| 159 | +27 |
- #' @order 3+ #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested. |
||
| 160 | +28 |
- summarize_num_patients <- function(lyt,+ #' |
||
| 161 | +29 |
- var,+ #' @examples |
||
| 162 | +30 |
- required = NULL,+ #' # Provide biomarker values and request actual values to be used, |
||
| 163 | +31 |
- count_by = NULL,+ #' # so that bandwidth is chosen from range. |
||
| 164 | +32 |
- unique_count_suffix = TRUE,+ #' control_step(biomarker = 1:10, use_percentile = FALSE) |
||
| 165 | +33 |
- na_str = default_na_str(),+ #' |
||
| 166 | +34 |
- .stats = NULL,+ #' # Use a global model with quadratic biomarker interaction term. |
||
| 167 | +35 |
- .formats = NULL,+ #' control_step(bandwidth = NULL, degree = 2) |
||
| 168 | +36 |
- .labels = c(+ #' |
||
| 169 | +37 |
- unique = "Number of patients with at least one event",+ #' # Reduce number of points to be used. |
||
| 170 | +38 |
- nonunique = "Number of events"+ #' control_step(num_points = 10) |
||
| 171 | +39 |
- ),+ #' |
||
| 172 | +40 |
- .indent_mods = 0L,+ #' @export |
||
| 173 | +41 |
- riskdiff = FALSE,+ control_step <- function(biomarker = NULL, |
||
| 174 | +42 |
- ...) {
+ use_percentile = TRUE, |
||
| 175 | -16x | +|||
| 43 | +
- checkmate::assert_flag(riskdiff)+ bandwidth, |
|||
| 176 | +44 |
-
+ degree = 0L,+ |
+ ||
| 45 | ++ |
+ num_points = 39L) {
|
||
| 177 | -5x | +46 | +31x |
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ checkmate::assert_numeric(biomarker, null.ok = TRUE) |
| 178 | -8x | +47 | +30x |
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ checkmate::assert_flag(use_percentile) |
| 179 | -+ | |||
| 48 | +30x |
-
+ checkmate::assert_int(num_points, lower = 2) |
||
| 180 | -16x | +49 | +29x |
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ checkmate::assert_count(degree) |
| 181 | +50 | |||
| 182 | -16x | +51 | +29x |
- cfun <- make_afun(+ if (missing(bandwidth)) {
|
| 183 | -16x | +|||
| 52 | +
- c_num_patients,+ # Infer bandwidth |
|||
| 184 | -16x | +53 | +21x |
- .stats = .stats,+ bandwidth <- if (use_percentile) {
|
| 185 | -16x | +54 | +18x |
- .formats = .formats,+ 0.25 |
| 186 | -16x | +55 | +21x |
- .labels = .labels+ } else if (!is.null(biomarker)) {
|
| 187 | -+ | |||
| 56 | +3x |
- )+ diff(range(biomarker, na.rm = TRUE)) / 4 |
||
| 188 | +57 |
-
+ } else {
|
||
| 189 | -16x | +|||
| 58 | +! |
- extra_args <- if (isFALSE(riskdiff)) {
+ NULL |
||
| 190 | -14x | +|||
| 59 | +
- s_args+ } |
|||
| 191 | +60 |
} else {
|
||
| 192 | -2x | +|||
| 61 | +
- list(+ # Check bandwidth |
|||
| 193 | -2x | +62 | +8x |
- afun = list("s_num_patients_content" = cfun),
+ if (!is.null(bandwidth)) {
|
| 194 | -2x | +63 | +5x |
- .stats = .stats,+ if (use_percentile) {
|
| 195 | -2x | +64 | +4x |
- .indent_mods = .indent_mods,+ assert_proportion_value(bandwidth) |
| 196 | -2x | +|||
| 65 | +
- s_args = s_args+ } else {
|
|||
| 197 | -+ | |||
| 66 | +1x |
- )+ checkmate::assert_scalar(bandwidth) |
||
| 198 | -+ | |||
| 67 | +1x |
- }+ checkmate::assert_true(bandwidth > 0) |
||
| 199 | +68 |
-
+ } |
||
| 200 | -16x | +|||
| 69 | +
- summarize_row_groups(+ } |
|||
| 201 | -16x | +|||
| 70 | +
- lyt = lyt,+ } |
|||
| 202 | -16x | +71 | +28x |
- var = var,+ list( |
| 203 | -16x | +72 | +28x |
- cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff),+ use_percentile = use_percentile, |
| 204 | -16x | +73 | +28x |
- na_str = na_str,+ bandwidth = bandwidth, |
| 205 | -16x | +74 | +28x |
- extra_args = extra_args,+ degree = as.integer(degree), |
| 206 | -16x | +75 | +28x |
- indent_mod = .indent_mods+ num_points = as.integer(num_points) |
| 207 | +76 |
) |
||
| 208 | +77 |
} |
| 209 | +1 |
-
+ #' Create a STEP graph |
||
| 210 | +2 |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ #' |
||
| 211 | +3 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 212 | +4 |
#' |
||
| 213 | +5 |
- #' @return+ #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR |
||
| 214 | +6 |
- #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions,+ #' along the continuous biomarker value subgroups. |
||
| 215 | +7 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 216 | +8 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ #' @param df (`tibble`)\cr result of [tidy.step()]. |
||
| 217 | +9 |
- #'+ #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual |
||
| 218 | +10 |
- #' @details In general, functions that starts with `analyze*` are expected to+ #' biomarker values. |
||
| 219 | +11 |
- #' work like [rtables::analyze()], while functions that starts with `summarize*`+ #' @param est (named `list`)\cr `col` and `lty` settings for estimate line. |
||
| 220 | +12 |
- #' are based upon [rtables::summarize_row_groups()]. The latter provides a+ #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval |
||
| 221 | +13 |
- #' value for each dividing split in the row and column space, but, being it+ #' ribbon area, or `NULL` to not plot a CI ribbon. |
||
| 222 | +14 |
- #' bound to the fundamental splits, it is repeated by design in every page+ #' @param col (`character`)\cr color(s). |
||
| 223 | +15 |
- #' when pagination is involved.+ #' |
||
| 224 | +16 | ++ |
+ #' @return A `ggplot` STEP graph.+ |
+ |
| 17 |
#' |
|||
| 225 | +18 |
- #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows.+ #' @seealso Custom tidy method [tidy.step()]. |
||
| 226 | +19 |
#' |
||
| 227 | +20 |
#' @examples |
||
| 228 | +21 |
- #' df <- data.frame(+ #' library(survival) |
||
| 229 | +22 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)),+ #' lung$sex <- factor(lung$sex) |
||
| 230 | +23 |
- #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
+ #' |
||
| 231 | +24 |
- #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17),+ #' # Survival example. |
||
| 232 | +25 |
- #' SEX = c("M", "M", "M", "F", "F", "F", "M", "F", "M")
+ #' vars <- list( |
||
| 233 | +26 |
- #' )+ #' time = "time", |
||
| 234 | +27 |
- #'+ #' event = "status", |
||
| 235 | +28 |
- #' # analyze_num_patients+ #' arm = "sex", |
||
| 236 | +29 |
- #' tbl <- basic_table() %>%+ #' biomarker = "age" |
||
| 237 | +30 |
- #' split_cols_by("ARM") %>%
+ #' ) |
||
| 238 | +31 |
- #' add_colcounts() %>%+ #' |
||
| 239 | +32 |
- #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
+ #' step_matrix <- fit_survival_step( |
||
| 240 | +33 |
- #' build_table(df)+ #' variables = vars, |
||
| 241 | +34 |
- #'+ #' data = lung, |
||
| 242 | +35 |
- #' tbl+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
||
| 243 | +36 |
- #'+ #' ) |
||
| 244 | +37 |
- #' @export+ #' step_data <- broom::tidy(step_matrix) |
||
| 245 | +38 |
- #' @order 2+ #' |
||
| 246 | +39 |
- analyze_num_patients <- function(lyt,+ #' # Default plot. |
||
| 247 | +40 |
- vars,+ #' g_step(step_data) |
||
| 248 | +41 |
- required = NULL,+ #' |
||
| 249 | +42 |
- count_by = NULL,+ #' # Add the reference 1 horizontal line. |
||
| 250 | +43 |
- unique_count_suffix = TRUE,+ #' library(ggplot2) |
||
| 251 | +44 |
- na_str = default_na_str(),+ #' g_step(step_data) + |
||
| 252 | +45 |
- nested = TRUE,+ #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2) |
||
| 253 | +46 |
- .stats = NULL,+ #' |
||
| 254 | +47 |
- .formats = NULL,+ #' # Use actual values instead of percentiles, different color for estimate and no CI, |
||
| 255 | +48 |
- .labels = c(+ #' # use log scale for y axis. |
||
| 256 | +49 |
- unique = "Number of patients with at least one event",+ #' g_step( |
||
| 257 | +50 |
- nonunique = "Number of events"+ #' step_data, |
||
| 258 | +51 |
- ),+ #' use_percentile = FALSE, |
||
| 259 | +52 |
- show_labels = c("default", "visible", "hidden"),
+ #' est = list(col = "blue", lty = 1), |
||
| 260 | +53 |
- .indent_mods = 0L,+ #' ci_ribbon = NULL |
||
| 261 | +54 |
- riskdiff = FALSE,+ #' ) + scale_y_log10() |
||
| 262 | +55 |
- ...) {
+ #' |
||
| 263 | -4x | +|||
| 56 | +
- checkmate::assert_flag(riskdiff)+ #' # Adding another curve based on additional column. |
|||
| 264 | +57 |
-
+ #' step_data$extra <- exp(step_data$`Percentile Center`) |
||
| 265 | -1x | +|||
| 58 | +
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ #' g_step(step_data) + |
|||
| 266 | -! | +|||
| 59 | +
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green") |
|||
| 267 | +60 |
-
+ #' |
||
| 268 | -4x | +|||
| 61 | +
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ #' # Response example. |
|||
| 269 | +62 |
-
+ #' vars <- list( |
||
| 270 | -4x | +|||
| 63 | +
- afun <- make_afun(+ #' response = "status", |
|||
| 271 | -4x | +|||
| 64 | +
- c_num_patients,+ #' arm = "sex", |
|||
| 272 | -4x | +|||
| 65 | +
- .stats = .stats,+ #' biomarker = "age" |
|||
| 273 | -4x | +|||
| 66 | +
- .formats = .formats,+ #' ) |
|||
| 274 | -4x | +|||
| 67 | +
- .labels = .labels+ #' |
|||
| 275 | +68 |
- )+ #' step_matrix <- fit_rsp_step( |
||
| 276 | +69 |
-
+ #' variables = vars, |
||
| 277 | -4x | +|||
| 70 | +
- extra_args <- if (isFALSE(riskdiff)) {
+ #' data = lung, |
|||
| 278 | -2x | +|||
| 71 | +
- s_args+ #' control = c( |
|||
| 279 | +72 |
- } else {
+ #' control_logistic(response_definition = "I(response == 2)"), |
||
| 280 | -2x | +|||
| 73 | +
- list(+ #' control_step() |
|||
| 281 | -2x | +|||
| 74 | +
- afun = list("s_num_patients_content" = afun),
+ #' ) |
|||
| 282 | -2x | +|||
| 75 | +
- .stats = .stats,+ #' ) |
|||
| 283 | -2x | +|||
| 76 | +
- .indent_mods = .indent_mods,+ #' step_data <- broom::tidy(step_matrix) |
|||
| 284 | -2x | +|||
| 77 | +
- s_args = s_args+ #' g_step(step_data) |
|||
| 285 | +78 |
- )+ #' |
||
| 286 | +79 |
- }+ #' @export |
||
| 287 | +80 |
-
+ g_step <- function(df, |
||
| 288 | -4x | +|||
| 81 | +
- analyze(+ use_percentile = "Percentile Center" %in% names(df), |
|||
| 289 | -4x | +|||
| 82 | +
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ est = list(col = "blue", lty = 1), |
|||
| 290 | -4x | +|||
| 83 | +
- lyt = lyt,+ ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
|
|||
| 291 | -4x | +|||
| 84 | +
- vars = vars,+ col = getOption("ggplot2.discrete.colour")) {
|
|||
| 292 | -4x | +85 | +2x |
- na_str = na_str,+ checkmate::assert_tibble(df) |
| 293 | -4x | +86 | +2x |
- nested = nested,+ checkmate::assert_flag(use_percentile) |
| 294 | -4x | +87 | +2x |
- extra_args = extra_args,+ checkmate::assert_character(col, null.ok = TRUE) |
| 295 | -4x | +88 | +2x |
- show_labels = show_labels,+ checkmate::assert_list(est, names = "named") |
| 296 | -4x | -
- indent_mod = .indent_mods- |
- ||
| 297 | -+ | 89 | +2x |
- )+ checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE) |
| 298 | +90 |
- }+ |
| 1 | -+ | |||
| 91 | +2x |
- #' Count patients with abnormal analysis range values by baseline status+ x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center") |
||
| 2 | -+ | |||
| 92 | +2x |
- #'+ df$x <- df[[x_var]] |
||
| 3 | -+ | |||
| 93 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ attrs <- attributes(df) |
||
| 4 | -+ | |||
| 94 | +2x |
- #'+ df$y <- df[[attrs$estimate]] |
||
| 5 | +95 |
- #' The analyze function [count_abnormal_by_baseline()] creates a layout element to count patients with abnormal+ |
||
| 6 | +96 |
- #' analysis range values, categorized by baseline status.+ # Set legend names. To be modified also at call level |
||
| 7 | -+ | |||
| 97 | +2x |
- #'+ legend_names <- c("Estimate", "CI 95%")
|
||
| 8 | +98 |
- #' This function analyzes primary analysis variable `var` which indicates abnormal range results. Additional+ |
||
| 9 | -+ | |||
| 99 | +2x |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to+ p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]])) |
||
| 10 | +100 |
- #' `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` (defaults to `BNRIND`), a+ |
||
| 11 | -+ | |||
| 101 | +2x |
- #' variable to indicate baseline reference ranges.+ if (!is.null(col)) {
|
||
| 12 | -+ | |||
| 102 | +2x |
- #'+ p <- p + |
||
| 13 | -+ | |||
| 103 | +2x |
- #' For each direction specified via the `abnormal` parameter (e.g. High or Low), we condition on baseline+ ggplot2::scale_color_manual(values = col) |
||
| 14 | +104 |
- #' range result and count patients in the numerator and denominator as follows for each of the following+ } |
||
| 15 | +105 |
- #' categories:+ |
||
| 16 | -+ | |||
| 106 | +2x |
- #' * `Not <abnormality>`+ if (!is.null(ci_ribbon)) {
|
||
| 17 | -+ | |||
| 107 | +1x |
- #' * `num`: The number of patients without abnormality at baseline (excluding those with missing baseline)+ if (is.null(ci_ribbon$fill)) {
|
||
| 18 | -+ | |||
| 108 | +! |
- #' and with at least one abnormality post-baseline.+ ci_ribbon$fill <- "lightblue" |
||
| 19 | +109 |
- #' * `denom`: The number of patients without abnormality at baseline (excluding those with missing baseline).+ } |
||
| 20 | -+ | |||
| 110 | +1x |
- #' * `<Abnormality>`+ p <- p + ggplot2::geom_ribbon( |
||
| 21 | -+ | |||
| 111 | +1x |
- #' * `num`: The number of patients with abnormality as baseline and at least one abnormality post-baseline.+ ggplot2::aes( |
||
| 22 | -+ | |||
| 112 | +1x |
- #' * `denom`: The number of patients with abnormality at baseline.+ ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]], |
||
| 23 | -+ | |||
| 113 | +1x |
- #' * `Total`+ fill = legend_names[2] |
||
| 24 | +114 |
- #' * `num`: The number of patients with at least one post-baseline record and at least one abnormality+ ), |
||
| 25 | -+ | |||
| 115 | +1x |
- #' post-baseline.+ alpha = ci_ribbon$alpha |
||
| 26 | +116 |
- #' * `denom`: The number of patients with at least one post-baseline record.+ ) + |
||
| 27 | -+ | |||
| 117 | +1x |
- #'+ scale_fill_manual( |
||
| 28 | -+ | |||
| 118 | +1x |
- #' This function assumes that `df` has been filtered to only include post-baseline records.+ name = "", values = c("CI 95%" = ci_ribbon$fill)
|
||
| 29 | +119 |
- #'+ ) |
||
| 30 | +120 |
- #' @inheritParams argument_convention+ } |
||
| 31 | -+ | |||
| 121 | +2x |
- #' @param abnormal (`character`)\cr values identifying the abnormal range level(s) in `.var`.+ suppressMessages(p <- p + |
||
| 32 | -+ | |||
| 122 | +2x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ ggplot2::geom_line( |
||
| 33 | -+ | |||
| 123 | +2x |
- #'+ ggplot2::aes(y = .data[["y"]], color = legend_names[1]), |
||
| 34 | -+ | |||
| 124 | +2x |
- #' Options are: ``r shQuote(get_stats("abnormal_by_baseline"))``
+ linetype = est$lty |
||
| 35 | +125 |
- #'+ ) + |
||
| 36 | -+ | |||
| 126 | +2x |
- #' @note+ scale_colour_manual( |
||
| 37 | -+ | |||
| 127 | +2x |
- #' * `df` should be filtered to include only post-baseline records.+ name = "", values = c("Estimate" = "blue")
|
||
| 38 | +128 |
- #' * If the baseline variable or analysis variable contains `NA` records, it is expected that `df` has been+ )) |
||
| 39 | +129 |
- #' pre-processed using [df_explicit_na()] or [explicit_na()].+ |
||
| 40 | -+ | |||
| 130 | +2x |
- #'+ p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate) |
||
| 41 | -+ | |||
| 131 | +2x |
- #' @seealso Relevant description function [d_count_abnormal_by_baseline()].+ if (use_percentile) {
|
||
| 42 | -+ | |||
| 132 | +1x |
- #'+ p <- p + ggplot2::scale_x_continuous(labels = scales::percent) |
||
| 43 | +133 |
- #' @name abnormal_by_baseline+ } |
||
| 44 | -+ | |||
| 134 | +2x |
- #' @order 1+ p |
||
| 45 | +135 |
- NULL+ } |
||
| 46 | +136 | |||
| 47 | +137 |
- #' Description function for `s_count_abnormal_by_baseline()`+ #' Custom tidy method for STEP results |
||
| 48 | +138 |
#' |
||
| 49 | +139 |
#' @description `r lifecycle::badge("stable")`
|
||
| 50 | +140 |
#' |
||
| 51 | +141 |
- #' Description function that produces the labels for [s_count_abnormal_by_baseline()].+ #' Tidy the STEP results into a `tibble` format ready for plotting. |
||
| 52 | +142 |
#' |
||
| 53 | -- |
- #' @inheritParams abnormal_by_baseline- |
- ||
| 54 | +143 |
- #'+ #' @param x (`matrix`)\cr results from [fit_survival_step()]. |
||
| 55 | +144 |
- #' @return Abnormal category labels for [s_count_abnormal_by_baseline()].+ #' @param ... not used. |
||
| 56 | +145 |
#' |
||
| 57 | +146 |
- #' @examples+ #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale, |
||
| 58 | +147 |
- #' d_count_abnormal_by_baseline("LOW")
+ #' respectively. Additional attributes carry metadata also used for plotting. |
||
| 59 | +148 |
#' |
||
| 60 | +149 |
- #' @export+ #' @seealso [g_step()] which consumes the result from this function. |
||
| 61 | +150 |
- d_count_abnormal_by_baseline <- function(abnormal) {
- |
- ||
| 62 | -9x | -
- not_abn_name <- paste("Not", tolower(abnormal))
- |
- ||
| 63 | -9x | -
- abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))- |
- ||
| 64 | -9x | -
- total_name <- "Total"+ #' |
||
| 65 | +151 | - - | -||
| 66 | -9x | -
- list(- |
- ||
| 67 | -9x | -
- not_abnormal = not_abn_name,- |
- ||
| 68 | -9x | -
- abnormal = abn_name,+ #' @method tidy step |
||
| 69 | -9x | +|||
| 152 | +
- total = total_name+ #' |
|||
| 70 | +153 |
- )+ #' @examples |
||
| 71 | +154 |
- }+ #' library(survival) |
||
| 72 | +155 |
-
+ #' lung$sex <- factor(lung$sex) |
||
| 73 | +156 |
- #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level.+ #' vars <- list( |
||
| 74 | +157 |
- #'+ #' time = "time", |
||
| 75 | +158 |
- #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with+ #' event = "status", |
||
| 76 | +159 |
- #' [df_explicit_na()]). The default is `"<Missing>"`.+ #' arm = "sex", |
||
| 77 | +160 |
- #'+ #' biomarker = "age" |
||
| 78 | +161 |
- #' @return+ #' ) |
||
| 79 | +162 |
- #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements:+ #' step_matrix <- fit_survival_step( |
||
| 80 | +163 |
- #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts.+ #' variables = vars, |
||
| 81 | +164 |
- #'+ #' data = lung, |
||
| 82 | +165 |
- #' @keywords internal+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
||
| 83 | +166 |
- s_count_abnormal_by_baseline <- function(df,+ #' ) |
||
| 84 | +167 |
- .var,+ #' broom::tidy(step_matrix) |
||
| 85 | +168 |
- abnormal,+ #' |
||
| 86 | +169 |
- na_str = "<Missing>",+ #' @export |
||
| 87 | +170 |
- variables = list(id = "USUBJID", baseline = "BNRIND")) {
+ tidy.step <- function(x, ...) { # nolint
|
||
| 88 | +171 | 7x |
- checkmate::assert_string(.var)+ checkmate::assert_class(x, "step") |
|
| 89 | +172 | 7x |
- checkmate::assert_string(abnormal)+ dat <- as.data.frame(x) |
|
| 90 | +173 | 7x |
- checkmate::assert_string(na_str)+ nams <- names(dat) |
|
| 91 | +174 | 7x |
- assert_df_with_variables(df, c(range = .var, variables))+ is_surv <- "loghr" %in% names(dat) |
|
| 92 | +175 | 7x |
- checkmate::assert_subset(names(variables), c("id", "baseline"))
+ est_var <- ifelse(is_surv, "loghr", "logor") |
|
| 93 | +176 | 7x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio") |
|
| 94 | +177 | 7x |
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
|
|
| 95 | +178 | 7x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ names(dat)[match(est_var, nams)] <- new_est_var |
|
| 96 | -+ | |||
| 179 | +7x |
-
+ dat[, new_y_vars] <- exp(dat[, new_y_vars]) |
||
| 97 | -+ | |||
| 180 | +7x |
- # If input is passed as character, changed to factor+ any_is_na <- any(is.na(dat[, new_y_vars])) |
||
| 98 | +181 | 7x |
- df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str)+ any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE) |
|
| 99 | +182 | 7x |
- df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str)+ if (any_is_na) {
|
|
| 100 | -+ | |||
| 183 | +2x |
-
+ warning(paste( |
||
| 101 | -7x | +184 | +2x |
- assert_valid_factor(df[[.var]], any.missing = FALSE)+ "Missing values in the point estimate or CI columns,", |
| 102 | -6x | +185 | +2x |
- assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)+ "this will lead to holes in the `g_step()` plot" |
| 103 | +186 |
-
+ )) |
||
| 104 | +187 |
- # Keep only records with valid analysis value.+ } |
||
| 105 | -5x | +188 | +7x |
- df <- df[df[[.var]] != na_str, ]+ if (any_is_very_large) {
|
| 106 | -+ | |||
| 189 | +2x |
-
+ warning(paste( |
||
| 107 | -5x | +190 | +2x |
- anl <- data.frame(+ "Very large absolute values in the point estimate or CI columns,", |
| 108 | -5x | +191 | +2x |
- id = df[[variables$id]],+ "consider adding `scale_y_log10()` to the `g_step()` result for plotting" |
| 109 | -5x | +|||
| 192 | +
- var = df[[.var]],+ )) |
|||
| 110 | -5x | +|||
| 193 | +
- baseline = df[[variables$baseline]],+ } |
|||
| 111 | -5x | +194 | +7x |
- stringsAsFactors = FALSE+ if (any_is_na || any_is_very_large) {
|
| 112 | -+ | |||
| 195 | +4x |
- )+ warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
|
||
| 113 | +196 |
-
+ } |
||
| 114 | -+ | |||
| 197 | +7x |
- # Total:+ structure( |
||
| 115 | -+ | |||
| 198 | +7x |
- # - Patients in denominator: have at least one valid measurement post-baseline.+ tibble::as_tibble(dat), |
||
| 116 | -+ | |||
| 199 | +7x |
- # - Patients in numerator: have at least one abnormality.+ estimate = new_est_var, |
||
| 117 | -5x | +200 | +7x |
- total_denom <- length(unique(anl$id))+ biomarker = attr(x, "variables")$biomarker, |
| 118 | -5x | +201 | +7x |
- total_num <- length(unique(anl$id[anl$var == abnormal]))+ ci = f_conf_level(attr(x, "control")$conf_level) |
| 119 | +202 |
-
+ ) |
||
| 120 | +203 |
- # Baseline NA records are counted only in total rows.+ } |
||
| 121 | -5x | +
| 1 | +
- anl <- anl[anl$baseline != na_str, ]+ #' Subgroup treatment effect pattern (STEP) fit for survival outcome |
|||
| 122 | +2 |
-
+ #' |
||
| 123 | +3 |
- # Abnormal:+ #' @description `r lifecycle::badge("stable")`
|
||
| 124 | +4 |
- # - Patients in denominator: have abnormality at baseline.+ #' |
||
| 125 | +5 |
- # - Patients in numerator: have abnormality at baseline AND+ #' This fits the subgroup treatment effect pattern (STEP) models for a survival outcome. The treatment arm |
||
| 126 | +6 |
- # have at least one abnormality post-baseline.+ #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated |
||
| 127 | -5x | +|||
| 7 | +
- abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))+ #' hazard ratios are for the comparison of the second level vs. the first one. |
|||
| 128 | -5x | +|||
| 8 | +
- abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))+ #' |
|||
| 129 | +9 |
-
+ #' The model which is fit is: |
||
| 130 | +10 |
- # Not abnormal:+ #' |
||
| 131 | +11 |
- # - Patients in denominator: do not have abnormality at baseline.+ #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
||
| 132 | +12 |
- # - Patients in numerator: do not have abnormality at baseline AND+ #' |
||
| 133 | +13 |
- # have at least one abnormality post-baseline.+ #' where `degree` is specified by `control_step()`. |
||
| 134 | -5x | +|||
| 14 | +
- not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))+ #' |
|||
| 135 | -5x | +|||
| 15 | +
- not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))+ #' @inheritParams argument_convention |
|||
| 136 | +16 |
-
+ #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`, |
||
| 137 | -5x | +|||
| 17 | +
- labels <- d_count_abnormal_by_baseline(abnormal)+ #' `arm`, `biomarker`, and optional `covariates` and `strata`. |
|||
| 138 | -5x | +|||
| 18 | +
- list(fraction = list(+ #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()]. |
|||
| 139 | -5x | +|||
| 19 | +
- not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),+ #' |
|||
| 140 | -5x | +|||
| 20 | +
- abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),+ #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used |
|||
| 141 | -5x | +|||
| 21 | +
- total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)+ #' for the biomarker variable, including where the center of the intervals are and their bounds. The |
|||
| 142 | +22 |
- ))+ #' second part of the columns contain the estimates for the treatment arm comparison. |
||
| 143 | +23 |
- }+ #' |
||
| 144 | +24 |
-
+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
||
| 145 | +25 |
- #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun`+ #' |
||
| 146 | +26 |
- #' in `count_abnormal_by_baseline()`.+ #' @seealso [control_step()] and [control_coxph()] for the available customization options. |
||
| 147 | +27 |
#' |
||
| 148 | +28 |
- #' @return+ #' @examples |
||
| 149 | +29 |
- #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ #' # Testing dataset with just two treatment arms. |
||
| 150 | +30 |
- #'+ #' library(dplyr) |
||
| 151 | +31 |
- #' @keywords internal+ #' |
||
| 152 | +32 |
- a_count_abnormal_by_baseline <- make_afun(+ #' adtte_f <- tern_ex_adtte %>% |
||
| 153 | +33 |
- s_count_abnormal_by_baseline,+ #' filter( |
||
| 154 | +34 |
- .formats = c(fraction = format_fraction)+ #' PARAMCD == "OS", |
||
| 155 | +35 |
- )+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 156 | +36 |
-
+ #' ) %>% |
||
| 157 | +37 |
- #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments+ #' mutate( |
||
| 158 | +38 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 159 | +39 |
- #'+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 160 | +40 |
- #' @return+ #' is_event = CNSR == 0 |
||
| 161 | +41 |
- #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions,+ #' ) |
||
| 162 | +42 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
|
||
| 163 | +43 |
- #' the statistics from `s_count_abnormal_by_baseline()` to the table layout.+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 164 | +44 |
#' |
||
| 165 | +45 |
- #' @examples+ #' variables <- list( |
||
| 166 | +46 |
- #' df <- data.frame(+ #' arm = "ARM", |
||
| 167 | +47 |
- #' USUBJID = as.character(c(1:6)),+ #' biomarker = "BMRKR1", |
||
| 168 | +48 |
- #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
+ #' covariates = c("AGE", "BMRKR2"),
|
||
| 169 | +49 |
- #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
+ #' event = "is_event", |
||
| 170 | +50 |
- #' )+ #' time = "AVAL" |
||
| 171 | +51 |
- #' df <- df_explicit_na(df)+ #' ) |
||
| 172 | +52 |
#' |
||
| 173 | +53 |
- #' # Layout creating function.+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
||
| 174 | +54 |
- #' basic_table() %>%+ #' step_matrix <- fit_survival_step( |
||
| 175 | +55 |
- #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%+ #' variables = variables, |
||
| 176 | +56 |
- #' build_table(df)+ #' data = adtte_f |
||
| 177 | +57 |
- #'+ #' ) |
||
| 178 | +58 |
- #' # Passing of statistics function and formatting arguments.+ #' dim(step_matrix) |
||
| 179 | +59 |
- #' df2 <- data.frame(+ #' head(step_matrix) |
||
| 180 | +60 |
- #' ID = as.character(c(1, 2, 3, 4)),+ #' |
||
| 181 | +61 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
||
| 182 | +62 |
- #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
+ #' # models. Or specify different Cox regression options. |
||
| 183 | +63 |
- #' )+ #' step_matrix2 <- fit_survival_step( |
||
| 184 | +64 |
- #'+ #' variables = variables, |
||
| 185 | +65 |
- #' basic_table() %>%+ #' data = adtte_f, |
||
| 186 | +66 |
- #' count_abnormal_by_baseline(+ #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2)) |
||
| 187 | +67 |
- #' var = "RANGE",+ #' ) |
||
| 188 | +68 |
- #' abnormal = c(Low = "LOW"),+ #' |
||
| 189 | +69 |
- #' variables = list(id = "ID", baseline = "BLRANGE"),+ #' # Use a global model with cubic interaction and only 5 points. |
||
| 190 | +70 |
- #' .formats = c(fraction = "xx / xx"),+ #' step_matrix3 <- fit_survival_step( |
||
| 191 | +71 |
- #' .indent_mods = c(fraction = 2L)+ #' variables = variables, |
||
| 192 | +72 |
- #' ) %>%+ #' data = adtte_f, |
||
| 193 | +73 |
- #' build_table(df2)+ #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L)) |
||
| 194 | +74 |
- #'+ #' ) |
||
| 195 | +75 |
- #' @export+ #' |
||
| 196 | +76 |
- #' @order 2+ #' @export |
||
| 197 | +77 |
- count_abnormal_by_baseline <- function(lyt,+ fit_survival_step <- function(variables, |
||
| 198 | +78 |
- var,+ data, |
||
| 199 | +79 |
- abnormal,+ control = c(control_step(), control_coxph())) {
|
||
| 200 | -+ | |||
| 80 | +4x |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ checkmate::assert_list(control) |
||
| 201 | -+ | |||
| 81 | +4x |
- na_str = "<Missing>",+ assert_df_with_variables(data, variables) |
||
| 202 | -+ | |||
| 82 | +4x |
- nested = TRUE,+ data <- data[!is.na(data[[variables$biomarker]]), ] |
||
| 203 | -+ | |||
| 83 | +4x |
- ...,+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
||
| 204 | -+ | |||
| 84 | +4x |
- table_names = abnormal,+ interval_center <- window_sel$interval[, "Interval Center"] |
||
| 205 | -+ | |||
| 85 | +4x |
- .stats = NULL,+ form <- h_step_survival_formula(variables = variables, control = control) |
||
| 206 | -+ | |||
| 86 | +4x |
- .formats = NULL,+ estimates <- if (is.null(control$bandwidth)) {
|
||
| 207 | -+ | |||
| 87 | +1x |
- .labels = NULL,+ h_step_survival_est( |
||
| 208 | -+ | |||
| 88 | +1x |
- .indent_mods = NULL) {
+ formula = form, |
||
| 209 | -2x | +89 | +1x |
- checkmate::assert_character(abnormal, len = length(table_names), names = "named")+ data = data, |
| 210 | -2x | +90 | +1x |
- checkmate::assert_string(var)+ variables = variables, |
| 211 | -+ | |||
| 91 | +1x |
-
+ x = interval_center, |
||
| 212 | -2x | +92 | +1x |
- extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...)+ control = control |
| 213 | +93 |
-
+ ) |
||
| 214 | -2x | +|||
| 94 | +
- afun <- make_afun(+ } else {
|
|||
| 215 | -2x | +95 | +3x |
- a_count_abnormal_by_baseline,+ tmp <- mapply( |
| 216 | -2x | +96 | +3x |
- .stats = .stats,+ FUN = h_step_survival_est, |
| 217 | -2x | +97 | +3x |
- .formats = .formats,+ x = interval_center, |
| 218 | -2x | +98 | +3x |
- .labels = .labels,+ subset = as.list(as.data.frame(window_sel$sel)), |
| 219 | -2x | +99 | +3x |
- .indent_mods = .indent_mods,+ MoreArgs = list( |
| 220 | -2x | +100 | +3x |
- .ungroup_stats = "fraction"+ formula = form, |
| 221 | -+ | |||
| 101 | +3x |
- )+ data = data, |
||
| 222 | -2x | +102 | +3x |
- for (i in seq_along(abnormal)) {
+ variables = variables, |
| 223 | -4x | +103 | +3x |
- extra_args[["abnormal"]] <- abnormal[i]+ control = control |
| 224 | +104 |
-
+ ) |
||
| 225 | -4x | +|||
| 105 | +
- lyt <- analyze(+ ) |
|||
| 226 | -4x | +|||
| 106 | +
- lyt = lyt,+ # Maybe we find a more elegant solution than this. |
|||
| 227 | -4x | +107 | +3x |
- vars = var,+ rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
|
| 228 | -4x | +108 | +3x |
- var_labels = names(abnormal[i]),+ t(tmp) |
| 229 | -4x | +|||
| 109 | +
- afun = afun,+ } |
|||
| 230 | +110 | 4x |
- na_str = na_str,+ result <- cbind(window_sel$interval, estimates) |
|
| 231 | +111 | 4x |
- nested = nested,+ structure( |
|
| 232 | +112 | 4x |
- table_names = table_names[i],+ result, |
|
| 233 | +113 | 4x |
- extra_args = extra_args,+ class = c("step", "matrix"),
|
|
| 234 | +114 | 4x |
- show_labels = "visible"+ variables = variables, |
|
| 235 | -+ | |||
| 115 | +4x |
- )+ control = control |
||
| 236 | +116 |
- }- |
- ||
| 237 | -2x | -
- lyt+ ) |
||
| 238 | +117 |
}@@ -185411,14 +184662,14 @@ tern coverage - 95.65% |
| 1 |
- #' Helper function to create a map data frame for `trim_levels_to_map()`+ #' Cumulative counts of numeric variable by thresholds |
||
| 5 |
- #' Helper function to create a map data frame from the input dataset, which can be used as an argument in the+ #' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a |
||
| 6 |
- #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.+ #' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified |
||
| 7 |
- #'+ #' threshold values. |
||
| 8 |
- #' @inheritParams argument_convention+ #' |
||
| 9 |
- #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of+ #' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds` |
||
| 10 |
- #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or+ #' argument as a numeric vector. Whether counts should include the threshold values, and whether to count |
||
| 11 |
- #' `abnormal = list(Low = "LOW", High = "HIGH"))`+ #' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail` |
||
| 12 |
- #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`.+ #' parameters, respectively. |
||
| 14 |
- #' @return A map `data.frame`.+ #' @inheritParams h_count_cumulative |
||
| 15 |
- #'+ #' @inheritParams argument_convention |
||
| 16 |
- #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the+ #' @param thresholds (`numeric`)\cr vector of cutoff values for the counts. |
||
| 17 |
- #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 18 |
- #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0+ #' |
||
| 19 |
- #' for low direction and at least one observation with high range is not missing for high direction.+ #' Options are: ``r shQuote(get_stats("count_cumulative"))``
|
||
| 21 |
- #' @examples+ #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]. |
||
| 22 |
- #' adlb <- df_explicit_na(tern_ex_adlb)+ #' |
||
| 23 |
- #'+ #' @name count_cumulative |
||
| 24 |
- #' h_map_for_count_abnormal(+ #' @order 1 |
||
| 25 |
- #' df = adlb,+ NULL |
||
| 26 |
- #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
+
|
||
| 27 |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ #' Helper function for `s_count_cumulative()` |
||
| 28 |
- #' method = "default",+ #' |
||
| 29 |
- #' na_str = "<Missing>"+ #' @description `r lifecycle::badge("stable")`
|
||
| 30 |
- #' )+ #' |
||
| 31 |
- #'+ #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold. |
||
| 32 |
- #' df <- data.frame(+ #' |
||
| 33 |
- #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
+ #' @inheritParams argument_convention |
||
| 34 |
- #' AVISIT = c(+ #' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`. |
||
| 35 |
- #' rep("WEEK 1", 2),
+ #' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`. |
||
| 36 |
- #' rep("WEEK 2", 2),
+ #' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in |
||
| 37 |
- #' rep("WEEK 1", 2),
+ #' count, default is `TRUE`. |
||
| 38 |
- #' rep("WEEK 2", 2),
+ #' |
||
| 39 |
- #' rep("WEEK 1", 2),
+ #' @return A named vector with items: |
||
| 40 |
- #' rep("WEEK 2", 2)
+ #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold |
||
| 41 |
- #' ),+ #' of user specification. |
||
| 42 |
- #' PARAM = rep(c("ALT", "CPR"), 6),
+ #' * `fraction`: the fraction of the count. |
||
| 43 |
- #' ANRIND = c(+ #' |
||
| 44 |
- #' "NORMAL", "NORMAL", "LOW",+ #' @seealso [count_cumulative] |
||
| 45 |
- #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
+ #' |
||
| 46 |
- #' ),+ #' @examples |
||
| 47 |
- #' ANRLO = rep(5, 12),+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 48 |
- #' ANRHI = rep(20, 12)+ #' x <- c(sample(1:10, 10), NA) |
||
| 49 |
- #' )+ #' .N_col <- length(x) |
||
| 50 |
- #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
+ #' |
||
| 51 |
- #' h_map_for_count_abnormal(+ #' h_count_cumulative(x, 5, .N_col = .N_col) |
||
| 52 |
- #' df = df,+ #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col) |
||
| 53 |
- #' variables = list(+ #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col) |
||
| 54 |
- #' anl = "ANRIND",+ #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col) |
||
| 55 |
- #' split_rows = c("PARAM"),
+ #' |
||
| 56 |
- #' range_low = "ANRLO",+ #' @export |
||
| 57 |
- #' range_high = "ANRHI"+ h_count_cumulative <- function(x, |
||
| 58 |
- #' ),+ threshold, |
||
| 59 |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ lower_tail = TRUE, |
||
| 60 |
- #' method = "range",+ include_eq = TRUE, |
||
| 61 |
- #' na_str = "<Missing>"+ na.rm = TRUE, # nolint |
||
| 62 |
- #' )+ .N_col) { # nolint
|
||
| 63 | -+ | 36x |
- #'+ checkmate::assert_numeric(x) |
| 64 | -+ | 36x |
- #' @export+ checkmate::assert_numeric(threshold) |
| 65 | -+ | 36x |
- h_map_for_count_abnormal <- function(df,+ checkmate::assert_numeric(.N_col) |
| 66 | -+ | 36x |
- variables = list(+ checkmate::assert_flag(lower_tail) |
| 67 | -+ | 36x |
- anl = "ANRIND",+ checkmate::assert_flag(include_eq) |
| 68 | -+ | 36x |
- split_rows = c("PARAM"),
+ checkmate::assert_flag(na.rm) |
| 69 |
- range_low = "ANRLO",+ |
||
| 70 | -+ | 36x |
- range_high = "ANRHI"+ is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x)) |
| 71 | -+ | 36x |
- ),+ count <- if (lower_tail && include_eq) {
|
| 72 | -+ | 7x |
- abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
+ length(x[is_keep & x <= threshold]) |
| 73 | -+ | 36x |
- method = c("default", "range"),
+ } else if (lower_tail && !include_eq) {
|
| 74 | -+ | ! |
- na_str = "<Missing>") {
+ length(x[is_keep & x < threshold]) |
| 75 | -7x | +36x |
- method <- match.arg(method)+ } else if (!lower_tail && include_eq) {
|
| 76 | -7x | +14x |
- checkmate::assert_subset(c("anl", "split_rows"), names(variables))
+ length(x[is_keep & x >= threshold]) |
| 77 | -7x | +36x |
- checkmate::assert_false(anyNA(df[variables$split_rows]))+ } else if (!lower_tail && !include_eq) {
|
| 78 | -7x | +15x |
- assert_df_with_variables(df,+ length(x[is_keep & x > threshold]) |
| 79 | -7x | +
- variables = list(anl = variables$anl, split_rows = variables$split_rows),+ } |
|
| 80 | -7x | +
- na_level = na_str+ |
|
| 81 | -+ | 36x |
- )+ result <- c( |
| 82 | -7x | +36x |
- assert_df_with_factors(df, list(val = variables$anl))+ count = count, |
| 83 | -7x | +36x |
- assert_valid_factor(df[[variables$anl]], any.missing = FALSE)+ fraction = if (count == 0 && .N_col == 0) 0 else count / .N_col |
| 84 | -7x | +
- assert_list_of_variables(variables)+ ) |
|
| 85 | -7x | +36x |
- checkmate::assert_list(abnormal, types = "character", len = 2)+ result |
| 86 |
-
+ } |
||
| 87 |
- # Drop usued levels from df as they are not supposed to be in the final map+ |
||
| 88 | -7x | +
- df <- droplevels(df)+ #' Description of cumulative count |
|
| 89 |
-
+ #' |
||
| 90 | -7x | +
- normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))+ #' @description `r lifecycle::badge("stable")`
|
|
| 91 |
-
+ #' |
||
| 92 |
- # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL"+ #' This is a helper function that describes the analysis in [s_count_cumulative()]. |
||
| 93 | -7x | +
- checkmate::assert_vector(normal_value, len = 1)+ #' |
|
| 94 |
-
+ #' @inheritParams h_count_cumulative |
||
| 95 |
- # Default method will only have what is observed in the df, and records with all normal values will be excluded to+ #' |
||
| 96 |
- # avoid error in layout building.+ #' @return Labels for [s_count_cumulative()]. |
||
| 97 | -7x | +
- if (method == "default") {
+ #' |
|
| 98 | -3x | +
- df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal))+ #' @export |
|
| 99 | -3x | +
- map <- unique(df_abnormal[c(variables$split_rows, variables$anl)])+ d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) {
|
|
| 100 | -3x | +34x |
- map_normal <- unique(subset(map, select = variables$split_rows))+ checkmate::assert_numeric(threshold) |
| 101 | -3x | +34x |
- map_normal[[variables$anl]] <- normal_value+ lg <- if (lower_tail) "<" else ">" |
| 102 | -3x | +34x |
- map <- rbind(map, map_normal)+ eq <- if (include_eq) "=" else "" |
| 103 | -4x | +34x |
- } else if (method == "range") {
+ paste0(lg, eq, " ", threshold) |
| 104 |
- # range method follows the rule that at least one observation with ANRLO > 0 for low+ } |
||
| 105 |
- # direction and at least one observation with ANRHI is not missing for high direction.+ |
||
| 106 | -4x | +
- checkmate::assert_subset(c("range_low", "range_high"), names(variables))
+ #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds. |
|
| 107 | -4x | +
- checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
+ #' |
|
| 108 |
-
+ #' @return |
||
| 109 | -4x | +
- assert_df_with_variables(df,+ #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a |
|
| 110 | -4x | +
- variables = list(+ #' component, each component containing a vector for the count and fraction. |
|
| 111 | -4x | +
- range_low = variables$range_low,+ #' |
|
| 112 | -4x | +
- range_high = variables$range_high+ #' @keywords internal |
|
| 113 |
- )+ s_count_cumulative <- function(x, |
||
| 114 |
- )+ thresholds, |
||
| 115 |
-
+ lower_tail = TRUE, |
||
| 116 |
- # Define low direction of map+ include_eq = TRUE, |
||
| 117 | -4x | +
- df_low <- subset(df, df[[variables$range_low]] > 0)+ .N_col, # nolint |
|
| 118 | -4x | +
- map_low <- unique(df_low[variables$split_rows])+ .N_row, # nolint |
|
| 119 | -4x | +
- low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"]))+ denom = c("N_col", "n", "N_row"),
|
|
| 120 | -4x | +
- low_levels_df <- as.data.frame(low_levels)+ ...) {
|
|
| 121 | -4x | +9x |
- colnames(low_levels_df) <- variables$anl+ checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) |
| 122 | -4x | +
- low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
+
|
|
| 123 | -4x | +9x |
- rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed+ denom <- match.arg(denom) %>% |
| 124 | -4x | +9x |
- map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE]+ switch( |
| 125 | -4x | +9x |
- map_low <- cbind(map_low, low_levels_df)+ n = length(x), |
| 126 | -+ | 9x |
-
+ N_row = .N_row, |
| 127 | -+ | 9x |
- # Define high direction of map+ N_col = .N_col |
| 128 | -4x | +
- df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]]))+ ) |
|
| 129 | -4x | +
- map_high <- unique(df_high[variables$split_rows])+ |
|
| 130 | -4x | +9x |
- high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"]))+ count_fraction_list <- Map(function(thres) {
|
| 131 | -4x | +18x |
- high_levels_df <- as.data.frame(high_levels)+ result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = denom, ...) |
| 132 | -4x | +18x |
- colnames(high_levels_df) <- variables$anl+ label <- d_count_cumulative(thres, lower_tail, include_eq) |
| 133 | -4x | +18x |
- high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
+ formatters::with_label(result, label) |
| 134 | -4x | +9x |
- rownames(map_high) <- NULL+ }, thresholds) |
| 135 | -4x | +
- map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE]+ |
|
| 136 | -4x | +9x |
- map_high <- cbind(map_high, high_levels_df)+ names(count_fraction_list) <- thresholds |
| 137 | -+ | 9x |
-
+ list(count_fraction = count_fraction_list) |
| 138 |
- # Define normal of map+ } |
||
| 139 | -4x | +
- map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])+ |
|
| 140 | -4x | +
- map_normal[variables$anl] <- normal_value+ #' @describeIn count_cumulative Formatted analysis function which is used as `afun` |
|
| 141 |
-
+ #' in `count_cumulative()`. |
||
| 142 | -4x | +
- map <- rbind(map_low, map_high, map_normal)+ #' |
|
| 143 |
- }+ #' @return |
||
| 144 |
-
+ #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 145 |
- # map should be all characters+ #' |
||
| 146 | -7x | +
- map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE)+ #' @keywords internal |
|
| 147 |
-
+ a_count_cumulative <- make_afun( |
||
| 148 |
- # sort the map final output by split_rows variables+ s_count_cumulative, |
||
| 149 | -7x | +
- for (i in rev(seq_len(length(variables$split_rows)))) {
+ .formats = c(count_fraction = format_count_fraction) |
|
| 150 | -7x | +
- map <- map[order(map[[i]]), ]+ ) |
|
| 151 |
- }+ |
||
| 152 | -7x | +
- map+ #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments |
|
| 153 |
- }+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
| 1 | +154 |
- #' Apply 1/3 or 1/2 imputation rule to data+ #' |
||
| 2 | +155 |
- #'+ #' @return |
||
| 3 | +156 |
- #' @description `r lifecycle::badge("stable")`
+ #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions, |
||
| 4 | +157 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 5 | +158 |
- #' @inheritParams argument_convention+ #' the statistics from `s_count_cumulative()` to the table layout. |
||
| 6 | +159 |
- #' @param x_stats (named `list`)\cr a named list of statistics, typically the results of [s_summary()].+ #' |
||
| 7 | +160 |
- #' @param stat (`string`)\cr statistic to return the value/NA level of according to the imputation+ #' @examples |
||
| 8 | +161 |
- #' rule applied.+ #' basic_table() %>% |
||
| 9 | +162 |
- #' @param imp_rule (`string`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation+ #' split_cols_by("ARM") %>%
|
||
| 10 | +163 |
- #' rule or `"1/2"` to implement 1/2 imputation rule.+ #' add_colcounts() %>% |
||
| 11 | +164 |
- #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`).+ #' count_cumulative( |
||
| 12 | +165 |
- #' This parameter is only used when `imp_rule` is set to `"1/3"`.+ #' vars = "AGE", |
||
| 13 | +166 |
- #' @param avalcat_var (`string`)\cr name of variable that indicates whether a row in `df` corresponds+ #' thresholds = c(40, 60) |
||
| 14 | +167 |
- #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above+ #' ) %>% |
||
| 15 | +168 |
- #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`.+ #' build_table(tern_ex_adsl) |
||
| 16 | +169 |
#' |
||
| 17 | +170 |
- #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed+ #' @export |
||
| 18 | +171 |
- #' according to the specified imputation rule.+ #' @order 2 |
||
| 19 | +172 |
- #'+ count_cumulative <- function(lyt, |
||
| 20 | +173 |
- #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule`+ vars, |
||
| 21 | +174 |
- #' argument.+ thresholds, |
||
| 22 | +175 |
- #'+ lower_tail = TRUE, |
||
| 23 | +176 |
- #' @examples+ include_eq = TRUE, |
||
| 24 | +177 |
- #' set.seed(1)+ var_labels = vars, |
||
| 25 | +178 |
- #' df <- data.frame(+ show_labels = "visible", |
||
| 26 | +179 |
- #' AVAL = runif(50, 0, 1),+ na_str = default_na_str(), |
||
| 27 | +180 |
- #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE)+ nested = TRUE, |
||
| 28 | +181 |
- #' )+ ..., |
||
| 29 | +182 |
- #' x_stats <- s_summary(df$AVAL)+ table_names = vars, |
||
| 30 | +183 |
- #' imputation_rule(df, x_stats, "max", "1/3")+ .stats = NULL, |
||
| 31 | +184 |
- #' imputation_rule(df, x_stats, "geom_mean", "1/3")+ .formats = NULL, |
||
| 32 | +185 |
- #' imputation_rule(df, x_stats, "mean", "1/2")+ .labels = NULL, |
||
| 33 | +186 |
- #'+ .indent_mods = NULL) {
|
||
| 34 | -+ | |||
| 187 | +3x |
- #' @export+ extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...) |
||
| 35 | +188 |
- imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
+
|
||
| 36 | -128x | +189 | +3x |
- checkmate::assert_choice(avalcat_var, names(df))+ afun <- make_afun( |
| 37 | -128x | +190 | +3x |
- checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
+ a_count_cumulative, |
| 38 | -128x | +191 | +3x |
- n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
+ .stats = .stats, |
| 39 | -128x | -
- ltr_blq_ratio <- n_blq / max(1, nrow(df))- |
- ||
| 40 | -+ | 192 | +3x |
-
+ .formats = .formats, |
| 41 | -+ | |||
| 193 | +3x |
- # defaults+ .labels = .labels, |
||
| 42 | -128x | +194 | +3x |
- val <- x_stats[[stat]]+ .indent_mods = .indent_mods, |
| 43 | -128x | +195 | +3x |
- na_str <- "NE"+ .ungroup_stats = "count_fraction" |
| 44 | +196 |
-
+ ) |
||
| 45 | -128x | +197 | +3x |
- if (imp_rule == "1/3") {
+ analyze( |
| 46 | -2x | +198 | +3x |
- if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT+ lyt, |
| 47 | -84x | +199 | +3x |
- if (ltr_blq_ratio > 1 / 3) {
+ vars, |
| 48 | -63x | +200 | +3x |
- if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT+ afun = afun, |
| 49 | -9x | +201 | +3x |
- if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
+ na_str = na_str, |
| 50 | -39x | -
- if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
- |
- ||
| 51 | -+ | 202 | +3x |
- }+ table_names = table_names, |
| 52 | -44x | +203 | +3x |
- } else if (imp_rule == "1/2") {
+ var_labels = var_labels, |
| 53 | -44x | +204 | +3x |
- if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
+ show_labels = show_labels, |
| 54 | -12x | +205 | +3x |
- val <- NA # 1/2_GT+ nested = nested, |
| 55 | -12x | -
- na_str <- "ND" # 1/2_GT- |
- ||
| 56 | -- |
- }- |
- ||
| 57 | -+ | 206 | +3x |
- }+ extra_args = extra_args |
| 58 | +207 | - - | -||
| 59 | -128x | -
- list(val = val, na_str = na_str)+ ) |
||
| 60 | +208 |
}@@ -186914,14 +186124,14 @@ tern coverage - 95.65% |
| 1 |
- #' Control function for incidence rate+ #' Control function for Cox-PH model |
||
| 5 |
- #' This is an auxiliary function for controlling arguments for the incidence rate, used+ #' This is an auxiliary function for controlling arguments for Cox-PH model, typically used internally to specify |
||
| 6 |
- #' internally to specify details in `s_incidence_rate()`.+ #' details of Cox-PH model for [s_coxph_pairwise()]. `conf_level` refers to Hazard Ratio estimation. |
||
| 9 |
- #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1. |
||
| 10 |
- #' for confidence interval type.+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
||
| 11 |
- #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' @param ties (`string`)\cr string specifying the method for tie handling. Default is `"efron"`, |
||
| 12 |
- #' indicating time unit for data input.+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]. |
||
| 13 |
- #' @param num_pt_year (`numeric(1)`)\cr number of patient-years to use when calculating adverse event rates.+ #' |
||
| 14 |
- #'+ #' @return A list of components with the same names as the arguments. |
||
| 15 |
- #' @return A list of components with the same names as the arguments.+ #' |
||
| 16 |
- #'+ #' @export |
||
| 17 |
- #' @seealso [incidence_rate]+ control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
|
||
| 18 |
- #'+ ties = c("efron", "breslow", "exact"),
|
||
| 19 |
- #' @examples+ conf_level = 0.95) {
|
||
| 20 | -+ | 52x |
- #' control_incidence_rate(0.9, "exact", "month", 100)+ pval_method <- match.arg(pval_method) |
| 21 | -+ | 51x |
- #'+ ties <- match.arg(ties) |
| 22 | -+ | 51x |
- #' @export+ assert_proportion_value(conf_level) |
| 23 |
- control_incidence_rate <- function(conf_level = 0.95,+ |
||
| 24 | -+ | 50x |
- conf_type = c("normal", "normal_log", "exact", "byar"),
+ list(pval_method = pval_method, ties = ties, conf_level = conf_level) |
| 25 |
- input_time_unit = c("year", "day", "week", "month"),
+ } |
||
| 26 |
- num_pt_year = 100) {
+
|
||
| 27 | -14x | +
- conf_type <- match.arg(conf_type)+ #' Control function for `survfit` models for survival time |
|
| 28 | -13x | +
- input_time_unit <- match.arg(input_time_unit)+ #' |
|
| 29 | -12x | +
- checkmate::assert_number(num_pt_year)+ #' @description `r lifecycle::badge("stable")`
|
|
| 30 | -11x | +
- assert_proportion_value(conf_level)+ #' |
|
| 31 |
-
+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify |
||
| 32 | -10x | +
- list(+ #' details of `survfit` model for [s_surv_time()]. `conf_level` refers to survival time estimation. |
|
| 33 | -10x | +
- conf_level = conf_level,+ #' |
|
| 34 | -10x | +
- conf_type = conf_type,+ #' @inheritParams argument_convention |
|
| 35 | -10x | +
- input_time_unit = input_time_unit,+ #' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
|
| 36 | -10x | +
- num_pt_year = num_pt_year+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
|
| 37 |
- )+ #' @param quantiles (`numeric(2)`)\cr vector of length two specifying the quantiles of survival time. |
||
| 38 |
- }+ #' |
| 1 | +39 |
- #' Summarize change from baseline values or absolute baseline values+ #' @return A list of components with the same names as the arguments. |
|
| 2 | +40 |
#' |
|
| 3 | +41 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
|
| 4 | +42 |
- #'+ control_surv_time <- function(conf_level = 0.95, |
|
| 5 | +43 |
- #' The analyze function [summarize_change()] creates a layout element to summarize the change from baseline or absolute+ conf_type = c("plain", "log", "log-log"),
|
|
| 6 | +44 |
- #' baseline values. The primary analysis variable `vars` indicates the numerical change from baseline results.+ quantiles = c(0.25, 0.75)) {
+ |
+ |
| 45 | +229x | +
+ conf_type <- match.arg(conf_type)+ |
+ |
| 46 | +228x | +
+ checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE)+ |
+ |
| 47 | +227x | +
+ nullo <- lapply(quantiles, assert_proportion_value)+ |
+ |
| 48 | +227x | +
+ assert_proportion_value(conf_level)+ |
+ |
| 49 | +226x | +
+ list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles) |
|
| 7 | +50 |
- #'+ } |
|
| 8 | +51 |
- #' Required secondary analysis variables `value` and `baseline_flag` can be supplied to the function via+ |
|
| 9 | +52 |
- #' the `variables` argument. The `value` element should be the name of the analysis value variable, and the+ #' Control function for `survfit` models for patients' survival rate at time points |
|
| 10 | +53 |
- #' `baseline_flag` element should be the name of the flag variable that indicates whether or not records contain+ #' |
|
| 11 | +54 |
- #' baseline values. Depending on the baseline flag given, either the absolute baseline values (at baseline)+ #' @description `r lifecycle::badge("stable")`
|
|
| 12 | +55 |
- #' or the change from baseline values (post-baseline) are then summarized.+ #' |
|
| 13 | +56 | ++ |
+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ |
+
| 57 | ++ |
+ #' details of `survfit` model for [s_surv_timepoint()]. `conf_level` refers to patient risk estimation at a time point.+ |
+ |
| 58 |
#' |
||
| 14 | +59 |
#' @inheritParams argument_convention |
|
| 15 | +60 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @inheritParams control_surv_time |
|
| 16 | +61 |
#' |
|
| 17 | +62 |
- #' Options are: ``r shQuote(get_stats("analyze_vars_numeric"))``
+ #' @return A list of components with the same names as the arguments. |
|
| 18 | +63 |
#' |
|
| 19 | +64 |
- #' @name summarize_change+ #' @export |
|
| 20 | +65 |
- #' @order 1+ control_surv_timepoint <- function(conf_level = 0.95, |
|
| 21 | +66 |
- NULL+ conf_type = c("plain", "log", "log-log")) {
+ |
+ |
| 67 | +24x | +
+ conf_type <- match.arg(conf_type)+ |
+ |
| 68 | +23x | +
+ assert_proportion_value(conf_level)+ |
+ |
| 69 | +22x | +
+ list(+ |
+ |
| 70 | +22x | +
+ conf_level = conf_level,+ |
+ |
| 71 | +22x | +
+ conf_type = conf_type |
|
| 22 | +72 |
-
+ ) |
|
| 23 | +73 |
- #' @describeIn summarize_change Statistics function that summarizes baseline or post-baseline visits.+ } |
| 24 | +1 |
- #'+ #' Generate PK reference dataset |
|
| 25 | +2 |
- #' @return+ #' |
|
| 26 | +3 |
- #' * `s_change_from_baseline()` returns the same values returned by [s_summary.numeric()].+ #' @description `r lifecycle::badge("stable")`
|
|
| 27 | +4 |
#' |
|
| 28 | +5 |
- #' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise+ #' @return A `data.frame` of PK parameters. |
|
| 29 | +6 |
- #' an error will be thrown.+ #' |
|
| 30 | +7 |
- #'+ #' @examples |
|
| 31 | +8 |
- #' @keywords internal+ #' pk_reference_dataset <- d_pkparam() |
|
| 32 | +9 |
- s_change_from_baseline <- function(df,+ #' |
|
| 33 | +10 |
- .var,+ #' @export |
|
| 34 | +11 |
- variables,+ d_pkparam <- function() {
|
|
| 12 | +4x | +
+ pk_dataset <- as.data.frame(matrix(+ |
+ |
| 13 | +4x | +
+ c(+ |
+ |
| 14 | +4x | +
+ "TMAX", "Time of CMAX", "Tmax", "Plasma/Blood/Serum", "1",+ |
+ |
| 15 | +4x | +
+ "CMAX", "Max Conc", "Cmax", "Plasma/Blood/Serum", "2",+ |
+ |
| 16 | +4x | +
+ "CMAXD", "Max Conc Norm by Dose", "Cmax/D", "Plasma/Blood/Serum", "3",+ |
+ |
| 17 | +4x | +
+ "AUCIFO", "AUC Infinity Obs", "AUCinf obs", "Plasma/Blood/Serum", "4",+ |
+ |
| 18 | +4x | +
+ "AUCIFP", "AUC Infinity Pred", "AUCinf pred", "Plasma/Blood/Serum", "5",+ |
+ |
| 19 | +4x | +
+ "AUCIFOD", "AUC Infinity Obs Norm by Dose", "AUCinf/D obs", "Plasma/Blood/Serum", "6",+ |
+ |
| 20 | +4x | +
+ "AUCIFD", "AUC Infinity Pred Norm by Dose", "AUCinf/D pred", "Plasma/Blood/Serum", "7",+ |
+ |
| 21 | +4x | +
+ "AUCPEO", "AUC %Extrapolation Obs", "AUCinf extrap obs", "Plasma/Blood/Serum", "8",+ |
+ |
| 22 | +4x | +
+ "AUCPEP", "AUC %Extrapolation Pred", "AUCinf extrap pred", "Plasma/Blood/Serum", "9",+ |
+ |
| 23 | +4x | +
+ "AUCINT", "AUC from T1 to T2", "AUCupper-lower ", "Plasma/Blood/Serum", "10",+ |
+ |
| 24 | +4x | +
+ "AUCTAU", "AUC Over Dosing Interval", "AUCtau", "Plasma/Blood/Serum", "11",+ |
+ |
| 25 | +4x | +
+ "AUCLST", "AUC to Last Nonzero Conc", "AUClast", "Plasma/Blood/Serum", "12",+ |
+ |
| 26 | +4x | +
+ "AUCALL", "AUC All", "AUCall", "Plasma/Blood/Serum", "13",+ |
+ |
| 27 | +4x | +
+ "AUMCIFO", "AUMC Infinity Obs", "AUMCinf obs", "Plasma/Blood/Serum", "14",+ |
+ |
| 28 | +4x | +
+ "AUMCIFP", "AUMC Infinity Pred", "AUMCinf pred", "Plasma/Blood/Serum", "15",+ |
+ |
| 29 | +4x | +
+ "AUMCPEO", "AUMC % Extrapolation Obs", "AUMC extrap obs", "Plasma/Blood/Serum", "16",+ |
+ |
| 30 | +4x | +
+ "AUMCPEP", "AUMC % Extrapolation Pred", "AUMC extrap pred", "Plasma/Blood/Serum", "17",+ |
+ |
| 31 | +4x | +
+ "AUMCTAU", "AUMC Over Dosing Interval", "AUMCtau", "Plasma/Blood/Serum", "18",+ |
+ |
| 32 | +4x | +
+ "AUMCLST", "AUMC to Last Nonzero Conc", "AUMClast", "Plasma/Blood/Serum", "19",+ |
+ |
| 33 | +4x | +
+ "AURCIFO", "AURC Infinity Obs", "AURCinf obs", "Plasma/Blood/Serum", "20",+ |
+ |
| 34 | +4x | +
+ "AURCIFP", "AURC Infinity Pred", "AURCinf pred", "Plasma/Blood/Serum", "21",+ |
+ |
| 35 | -+ | 4x |
- na.rm = TRUE, # nolint+ "AURCPEO", "AURC % Extrapolation Obs", "AURC extrap obs", "Plasma/Blood/Serum", "22", |
| 36 | -+ | 4x |
- ...) {
+ "AURCPEP", "AURC % Extrapolation Pred", "AURC extrap pred", "Plasma/Blood/Serum", "23", |
| 37 | 4x |
- checkmate::assert_numeric(df[[variables$value]])+ "AURCLST", "AURC Dosing to Last Conc", "AURClast", "Plasma/Blood/Serum", "24", |
|
| 38 | 4x |
- checkmate::assert_numeric(df[[.var]])+ "AURCALL", "AURC All", "AURCall", "Plasma/Blood/Serum", "25", |
|
| 39 | 4x |
- checkmate::assert_logical(df[[variables$baseline_flag]])+ "TLST", "Time of Last Nonzero Conc", "Tlast", "Plasma/Blood/Serum", "26", |
|
| 40 | 4x |
- checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1)+ "CO", "Initial Conc", "CO", "Plasma/Blood/Serum", "27", |
|
| 41 | 4x |
- assert_df_with_variables(df, c(variables, list(chg = .var)))+ "C0", "Initial Conc", "C0", "Plasma/Blood/Serum", "28", |
|
| 42 | -+ | 4x |
-
+ "CAVG", "Average Conc", "Cavg", "Plasma/Blood/Serum", "29", |
| 43 | 4x |
- combined <- ifelse(+ "CLST", "Last Nonzero Conc", "Clast", "Plasma/Blood/Serum", "30", |
|
| 44 | 4x |
- df[[variables$baseline_flag]],+ "CMIN", "Min Conc", "Cmin", "Plasma/Blood/Serum", "31", |
|
| 45 | 4x |
- df[[variables$value]],+ "LAMZHL", "Half-Life Lambda z", "t1/2", "Plasma/Blood/Serum", "32", |
|
| 46 | 4x |
- df[[.var]]+ "CLFO", "Total CL Obs by F", "CL/F obs", "Plasma/Blood/Serum", "33", |
|
| 47 | -+ | 4x |
- )+ "CLFP", "Total CL Pred by F", "CL/F pred", "Plasma/Blood/Serum", "34", |
| 48 | 4x |
- if (is.logical(combined) && identical(length(combined), 0L)) {
+ "CLO", "Total CL Obs", "CL obs", "Plasma/Blood/Serum", "35", |
|
| 49 | -1x | +4x |
- combined <- numeric(0)+ "CLP", "Total CL Pred", "CL pred", "Plasma/Blood/Serum", "36", |
| 50 | -+ | 4x |
- }+ "CLSS", "Total CL Steady State Pred", "CLss", "Plasma/Blood/Serum", "37", |
| 51 | 4x |
- s_summary(combined, na.rm = na.rm, ...)+ "CLSSF", "Total CL Steady State Pred by F", "CLss/F", "Plasma/Blood/Serum", "38", |
|
| 52 | -+ | 4x |
- }+ "VZFO", "Vz Obs by F", "Vz/F obs", "Plasma/Blood/Serum", "39", |
| 53 | -+ | 4x |
-
+ "VZFP", "Vz Pred by F", "Vz/F pred", "Plasma/Blood/Serum", "40", |
| 54 | -+ | 4x |
- #' @describeIn summarize_change Formatted analysis function which is used as `afun` in `summarize_change()`.+ "VZO", "Vz Obs", "Vz obs", "Plasma/Blood/Serum", "41", |
| 55 | -+ | 4x |
- #'+ "VZP", "Vz Pred", "Vz pred", "Plasma/Blood/Serum", "42", |
| 56 | -+ | 4x |
- #' @return+ "VSSO", "Vol Dist Steady State Obs", "Vss obs", "Plasma/Blood/Serum", "43", |
| 57 | -+ | 4x |
- #' * `a_change_from_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ "VSSP", "Vol Dist Steady State Pred", "Vss pred", "Plasma/Blood/Serum", "44", |
| 58 | -+ | 4x |
- #'+ "LAMZ", "Lambda z", "Lambda z", "Plasma/Blood/Serum", "45", |
| 59 | -+ | 4x |
- #' @keywords internal+ "LAMZLL", "Lambda z Lower Limit", "Lambda z lower", "Plasma/Blood/Serum", "46", |
| 60 | -+ | 4x |
- a_change_from_baseline <- make_afun(+ "LAMZUL", "Lambda z Upper Limit", "Lambda z upper", "Plasma/Blood/Serum", "47", |
| 61 | -+ | 4x |
- s_change_from_baseline,+ "LAMZNPT", "Number of Points for Lambda z", "No points Lambda z", "Plasma/Blood/Serum", "48", |
| 62 | -+ | 4x |
- .formats = c(+ "MRTIFO", "MRT Infinity Obs", "MRTinf obs", "Plasma/Blood/Serum", "49", |
| 63 | -+ | 4x |
- n = "xx",+ "MRTIFP", "MRT Infinity Pred", "MRTinf pred", "Plasma/Blood/Serum", "50", |
| 64 | -+ | 4x |
- mean_sd = "xx.xx (xx.xx)",+ "MRTLST", "MRT to Last Nonzero Conc", "MRTlast", "Plasma/Blood/Serum", "51", |
| 65 | -+ | 4x |
- mean_se = "xx.xx (xx.xx)",+ "R2", "R Squared", "Rsq", "Plasma/Blood/Serum", "52", |
| 66 | -+ | 4x |
- median = "xx.xx",+ "R2ADJ", "R Squared Adjusted", "Rsq adjusted", "Plasma/Blood/Serum", "53", |
| 67 | -+ | 4x |
- range = "xx.xx - xx.xx",+ "TLAG", "Time Until First Nonzero Conc", "TIag", "Plasma/Blood/Serum", "54", |
| 68 | -+ | 4x |
- mean_ci = "(xx.xx, xx.xx)",+ "TMIN", "Time of CMIN Observation", "Tmin", "Plasma/Blood/Serum", "55", |
| 69 | -+ | 4x |
- median_ci = "(xx.xx, xx.xx)",+ "ACCI", "Accumulation Index", "Accumulation Index", "Plasma/Blood/Serum/Urine", "56", |
| 70 | -+ | 4x |
- mean_pval = "xx.xx"+ "FLUCP", "Fluctuation%", "Fluctuation", "Plasma/Blood/Serum", "57", |
| 71 | -+ | 4x |
- ),+ "CORRXY", "Correlation Between TimeX and Log ConcY", "Corr xy", "Plasma/Blood/Serum", "58", |
| 72 | -+ | 4x |
- .labels = c(+ "RCAMINT", "Amt Rec from T1 to T2", "Ae", "Urine", "59", |
| 73 | -+ | 4x |
- mean_sd = "Mean (SD)",+ "RCPCINT", "Pct Rec from T1 to T2", "Fe", "Urine", "60", |
| 74 | -+ | 4x |
- mean_se = "Mean (SE)",+ "VOLPK", "Sum of Urine Vol", "Urine volume", "Urine", "61", |
| 75 | -+ | 4x |
- median = "Median",+ "RENALCL", "Renal CL", "CLR", "Plasma/Blood/Serum/Urine", "62", |
| 76 | -+ | 4x |
- range = "Min - Max"+ "ERTMAX", "Time of Max Excretion Rate", "Tmax Rate", "Urine", "63", |
| 77 | -+ | 4x |
- )+ "RMAX", "Time of Maximum Response", "Rmax", "Matrix of PD", "64", |
| 78 | -+ | 4x |
- )+ "RMIN", "Time of Minimum Response", "Rmin", "Matrix of PD", "65", |
| 79 | -+ | 4x |
-
+ "ERMAX", "Max Excretion Rate", "Max excretion rate", "Urine", "66", |
| 80 | -+ | 4x |
- #' @describeIn summarize_change Layout-creating function which can take statistics function arguments+ "MIDPTLST", "Midpoint of Collection Interval", "Midpoint last", "Urine", "67", |
| 81 | -+ | 4x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ "ERLST", "Last Meas Excretion Rate", "Rate last", "Urine", "68", |
| 82 | -+ | 4x |
- #'+ "TON", "Time to Onset", "Tonset", "Matrix of PD", "69", |
| 83 | -+ | 4x |
- #' @return+ "TOFF", "Time to Offset", "Toffset", "Matrix of PD", "70", |
| 84 | -+ | 4x |
- #' * `summarize_change()` returns a layout object suitable for passing to further layouting functions,+ "TBBLP", "Time Below Baseline %", "Time %Below Baseline", "Matrix of PD", "71", |
| 85 | -+ | 4x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ "TBTP", "Time Below Threshold %", "Time %Below Threshold", "Matrix of PD", "72", |
| 86 | -+ | 4x |
- #' the statistics from `s_change_from_baseline()` to the table layout.+ "TABL", "Time Above Baseline", "Time Above Baseline", "Matrix of PD", "73", |
| 87 | -+ | 4x |
- #'+ "TAT", "Time Above Threshold", "Time Above Threshold", "Matrix of PD", "74", |
| 88 | -+ | 4x |
- #' @note To be used after a split on visits in the layout, such that each data subset only contains+ "TBT", "Time Below Threshold", "Time Below Threshold", "Matrix of PD", "75", |
| 89 | -+ | 4x |
- #' either baseline or post-baseline data.+ "TBLT", "Time Between Baseline and Threshold", "Time Between Baseline Threshold", "Matrix of PD", "76", |
| 90 | -+ | 4x |
- #'+ "BLRSP", "Baseline Response", "Baseline", "Matrix of PD", "77", |
| 91 | -+ | 4x |
- #' @examples+ "TSHDRSP", "Response Threshold", "Threshold", "Matrix of PD", "78", |
| 92 | -+ | 4x |
- #' library(dplyr)+ "AUCABL", "AUC Above Baseline", "AUC above baseline", "Matrix of PD", "79", |
| 93 | -+ | 4x |
- #'+ "AUCAT", "AUC Above Threshold", "AUC above threshold", "Matrix of PD", "80", |
| 94 | -+ | 4x |
- #' ## Fabricate dataset+ "AUCBBL", "AUC Below Baseline", "AUC below baseline", "Matrix of PD", "81", |
| 95 | -+ | 4x |
- #' dta_test <- data.frame(+ "AUCBT", "AUC Below Threshold", "AUC below threshold", "Matrix of PD", "82", |
| 96 | -+ | 4x |
- #' USUBJID = rep(1:6, each = 3),+ "AUCBLDIF", "Diff AUC Above Base and AUC Below Base", "AUC diff baseline", "Matrix of PD", "83", |
| 97 | -+ | 4x |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ "AUCTDIF", "Diff AUC Above Thr and AUC Below Thr", "AUCnet threshold", "Matrix of PD", "84", |
| 98 | -+ | 4x |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ "TDIFF", "Diff Time to Offset and Time to Onset", "Diff toffset-tonset", "Matrix of PD", "85", |
| 99 | -+ | 4x |
- #' AVAL = c(9:1, rep(NA, 9))+ "AUCPBEO", "AUC %Back Extrapolation Obs", "AUC%Back extrap obs", "Plasma/Blood/Serum", "86", |
| 100 | -+ | 4x |
- #' ) %>%+ "AUCPBEP", "AUC %Back Extrapolation Pred", "AUC%Back extrap pred", "Plasma/Blood/Serum", "87", |
| 101 | -+ | 4x |
- #' mutate(ABLFLL = AVISIT == "V1") %>%+ "TSLP1L", "Lower Time Limit Slope 1st", "Slope1 lower", "Matrix of PD", "88", |
| 102 | -+ | 4x |
- #' group_by(USUBJID) %>%+ "TSLP1U", "Upper Time Limit Slope 1st Segment", "Slope1 upper", "Matrix of PD", "89", |
| 103 | -+ | 4x |
- #' mutate(+ "TSLP2L", "Lower Time Limit Slope 2nd Segment", "Slope2 lower", "Matrix of PD", "90", |
| 104 | -+ | 4x |
- #' BLVAL = AVAL[ABLFLL],+ "TSLP2U", "Upper Time Limit Slope 2nd Segment", "Slope2 upper", "Matrix of PD", "91", |
| 105 | -+ | 4x |
- #' CHG = AVAL - BLVAL+ "SLP1", "Slope, 1st Segment", "Slope1", "Matrix of PD", "92", |
| 106 | -+ | 4x |
- #' ) %>%+ "SLP2", "Slope, 2nd Segment", "Slope2", "Matrix of PD", "93", |
| 107 | -+ | 4x |
- #' ungroup()+ "SLP1PT", "Number of Points for Slope 1st Segment", "No points slope1", "Matrix of PD", "94", |
| 108 | -+ | 4x |
- #'+ "SLP2PT", "Number of Points for Slope 2nd Segment", "No points slope2", "Matrix of PD", "95", |
| 109 | -+ | 4x |
- #' results <- basic_table() %>%+ "R2ADJS1", "R-Squared Adjusted Slope, 1st Segment", "Rsq adjusted slope1", "Matrix of PD", "96", |
| 110 | -+ | 4x |
- #' split_cols_by("ARM") %>%
+ "R2ADJS2", "R-Squared Adjusted Slope, 2nd Segment", "Rsq adjusted slope2", "Matrix of PD", "97", |
| 111 | -+ | 4x |
- #' split_rows_by("AVISIT") %>%
+ "R2SLP1", "R Squared, Slope, 1st Segment", "Rsq slope1", "Matrix of PD", "98", |
| 112 | -+ | 4x |
- #' summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
+ "R2SLP2", "R Squared, Slope, 2nd Segment", "Rsq slope2", "Matrix of PD", "99", |
| 113 | -+ | 4x |
- #' build_table(dta_test)+ "CORRXYS1", "Corr Btw TimeX and Log ConcY, Slope 1st", "Corr xy slope1", "Plasma/Blood/Serum", "100", |
| 114 | -+ | 4x |
- #'+ "CORRXYS2", "Corr Btw TimeX and Log ConcY, Slope 1st Slope 2nd", "Corr xy slope2", "Plasma/Blood/Serum", "101", |
| 115 | -+ | 4x |
- #' results+ "AILAMZ", "Accumulation Index using Lambda z", "AILAMZ", "Plasma/Blood/Serum", "102", |
| 116 | -+ | 4x |
- #'+ "ARAUC", "Accumulation Ratio AUCTAU", "ARAUC", "Plasma/Blood/Serum", "103", |
| 117 | -+ | 4x |
- #' @export+ "ARAUCD", "Accum Ratio AUCTAU norm by dose", "ARAUCD", "Plasma/Blood/Serum", "104", |
| 118 | -+ | 4x |
- #' @order 2+ "ARAUCIFO", "Accum Ratio AUC Infinity Obs", "ARAUCIFO", "Plasma/Blood/Serum", "105", |
| 119 | -+ | 4x |
- summarize_change <- function(lyt,+ "ARAUCIFP", "Accum Ratio AUC Infinity Pred", "ARAUCIFP", "Plasma/Blood/Serum", "106", |
| 120 | -+ | 4x |
- vars,+ "ARAUCIND", "Accum Ratio AUC T1 to T2 norm by dose", "ARAUCIND_T1_T2_UNIT", "Plasma/Blood/Serum", "107", |
| 121 | -+ | 4x |
- variables,+ "ARAUCINT", "Accumulation Ratio AUC from T1 to T2", "ARAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "108", |
| 122 | -+ | 4x |
- na_str = default_na_str(),+ "ARAUCIOD", "Accum Ratio AUCIFO Norm by Dose", "ARAUCIOD", "Plasma/Blood/Serum", "109", |
| 123 | -+ | 4x |
- nested = TRUE,+ "ARAUCIPD", "Accum Ratio AUCIFP Norm by Dose", "ARAUCIPD", "Plasma/Blood/Serum", "110", |
| 124 | -+ | 4x |
- ...,+ "ARAUCLST", "Accum Ratio AUC to Last Nonzero Conc", "ARAUCLST", "Plasma/Blood/Serum", "111", |
| 125 | -+ | 4x |
- table_names = vars,+ "ARCMAX", "Accumulation Ratio Cmax", "ARCMAX", "Plasma/Blood/Serum", "112", |
| 126 | -+ | 4x |
- .stats = c("n", "mean_sd", "median", "range"),
+ "ARCMAXD", "Accum Ratio Cmax norm by dose", "ARCMAXD", "Plasma/Blood/Serum", "113", |
| 127 | -+ | 4x |
- .formats = NULL,+ "ARCMIN", "Accumulation Ratio Cmin", "ARCMIN", "Plasma/Blood/Serum", "114", |
| 128 | -+ | 4x |
- .labels = NULL,+ "ARCMIND", "Accum Ratio Cmin norm by dose", "ARCMIND", "Plasma/Blood/Serum", "115", |
| 129 | -+ | 4x |
- .indent_mods = NULL) {
+ "ARCTROUD", "Accum Ratio Ctrough norm by dose", "ARCTROUD", "Plasma/Blood/Serum", "116", |
| 130 | -1x | +4x |
- extra_args <- list(variables = variables, ...)+ "ARCTROUG", "Accumulation Ratio Ctrough", "ARCTROUG", "Plasma/Blood/Serum", "117", |
| 131 | -+ | 4x |
-
+ "AUCALLB", "AUC All Norm by BMI", "AUCall_B", "Plasma/Blood/Serum", "118", |
| 132 | -1x | +4x |
- afun <- make_afun(+ "AUCALLD", "AUC All Norm by Dose", "AUCall_D", "Plasma/Blood/Serum", "119", |
| 133 | -1x | +4x |
- a_change_from_baseline,+ "AUCALLS", "AUC All Norm by SA", "AUCall_S", "Plasma/Blood/Serum", "120", |
| 134 | -1x | +4x |
- .stats = .stats,+ "AUCALLW", "AUC All Norm by WT", "AUCall_W", "Plasma/Blood/Serum", "121", |
| 135 | -1x | +4x |
- .formats = .formats,+ "AUCIFOB", "AUC Infinity Obs Norm by BMI", "AUCINF_obs_B", "Plasma/Blood/Serum", "122", |
| 136 | -1x | +4x |
- .labels = .labels,+ "AUCIFOLN", "AUC Infinity Obs LN Transformed", "AUCIFOLN", "Plasma/Blood/Serum", "123", |
| 137 | -1x | +4x |
- .indent_mods = .indent_mods+ "AUCIFOS", "AUC Infinity Obs Norm by SA", "AUCINF_obs_S", "Plasma/Blood/Serum", "124", |
| 138 | -+ | 4x |
- )+ "AUCIFOUB", "AUC Infinity Obs, Unbound Drug", "AUCIFOUB", "Plasma/Blood/Serum", "125", |
| 139 | -+ | 4x |
-
+ "AUCIFOW", "AUC Infinity Obs Norm by WT", "AUCINF_obs_W", "Plasma/Blood/Serum", "126", |
| 140 | -1x | +4x |
- analyze(+ "AUCIFPB", "AUC Infinity Pred Norm by BMI", "AUCINF_pred_B", "Plasma/Blood/Serum", "127", |
| 141 | -1x | +4x |
- lyt,+ "AUCIFPD", "AUC Infinity Pred Norm by Dose", "AUCINF_pred_D", "Plasma/Blood/Serum", "128", |
| 142 | -1x | +4x |
- vars,+ "AUCIFPS", "AUC Infinity Pred Norm by SA", "AUCINF_pred_S", "Plasma/Blood/Serum", "129", |
| 143 | -1x | +4x |
- afun = afun,+ "AUCIFPUB", "AUC Infinity Pred, Unbound Drug", "AUCIFPUB", "Plasma/Blood/Serum", "130", |
| 144 | -1x | +4x |
- na_str = na_str,+ "AUCIFPW", "AUC Infinity Pred Norm by WT", "AUCINF_pred_W", "Plasma/Blood/Serum", "131", |
| 145 | -1x | +4x |
- nested = nested,+ "AUCINTB", "AUC from T1 to T2 Norm by BMI", "AUC_B_T1_T2_UNIT", "Plasma/Blood/Serum", "132", |
| 146 | -1x | +4x |
- extra_args = extra_args,+ "AUCINTD", "AUC from T1 to T2 Norm by Dose", "AUC_D_T1_T2_UNIT", "Plasma/Blood/Serum", "133", |
| 147 | -1x | +4x |
- table_names = table_names+ "AUCINTS", "AUC from T1 to T2 Norm by SA", "AUC_S_T1_T2_UNIT", "Plasma/Blood/Serum", "134", |
| 148 | -+ | 4x |
- )+ "AUCINTW", "AUC from T1 to T2 Norm by WT", "AUC_W_T1_T2_UNIT", "Plasma/Blood/Serum", "135", |
| 149 | -+ | 4x |
- }+ "AUCLSTB", "AUC to Last Nonzero Conc Norm by BMI", "AUClast_B", "Plasma/Blood/Serum", "136", |
| 1 | -+ | ||
| 150 | +4x |
- #' Sort pharmacokinetic data by `PARAM` variable+ "AUCLSTD", "AUC to Last Nonzero Conc Norm by Dose", "AUClast_D", "Plasma/Blood/Serum", "137", |
|
| 2 | -+ | ||
| 151 | +4x |
- #'+ "AUCLSTLN", "AUC to Last Nonzero Conc LN Transformed", "AUCLSTLN", "Plasma/Blood/Serum", "138", |
|
| 3 | -+ | ||
| 152 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ "AUCLSTS", "AUC to Last Nonzero Conc Norm by SA", "AUClast_S", "Plasma/Blood/Serum", "139", |
|
| 4 | -+ | ||
| 153 | +4x |
- #'+ "AUCLSTUB", "AUC to Last Nonzero Conc, Unbound Drug", "AUCLSTUB", "Plasma/Blood/Serum", "140", |
|
| 5 | -+ | ||
| 154 | +4x |
- #' @param pk_data (`data.frame`)\cr pharmacokinetic data frame.+ "AUCLSTW", "AUC to Last Nonzero Conc Norm by WT", "AUClast_W", "Plasma/Blood/Serum", "141", |
|
| 6 | -+ | ||
| 155 | +4x |
- #' @param key_var (`string`)\cr key variable used to merge pk_data and metadata created by [d_pkparam()].+ "AUCTAUB", "AUC Over Dosing Interval Norm by BMI", "AUC_TAU_B", "Plasma/Blood/Serum", "142", |
|
| 7 | -+ | ||
| 156 | +4x |
- #'+ "AUCTAUD", "AUC Over Dosing Interval Norm by Dose", "AUC_TAU_D", "Plasma/Blood/Serum", "143", |
|
| 8 | -+ | ||
| 157 | +4x |
- #' @return A pharmacokinetic `data.frame` sorted by a `PARAM` variable.+ "AUCTAUS", "AUC Over Dosing Interval Norm by SA", "AUC_TAU_S", "Plasma/Blood/Serum", "144", |
|
| 9 | -+ | ||
| 158 | +4x |
- #'+ "AUCTAUW", "AUC Over Dosing Interval Norm by WT", "AUC_TAU_W", "Plasma/Blood/Serum", "145", |
|
| 10 | -+ | ||
| 159 | +4x |
- #' @examples+ "AUMCIFOB", "AUMC Infinity Obs Norm by BMI", "AUMCINF_obs_B", "Plasma/Blood/Serum", "146", |
|
| 11 | -+ | ||
| 160 | +4x |
- #' library(dplyr)+ "AUMCIFOD", "AUMC Infinity Obs Norm by Dose", "AUMCINF_obs_D", "Plasma/Blood/Serum", "147", |
|
| 12 | -+ | ||
| 161 | +4x |
- #'+ "AUMCIFOS", "AUMC Infinity Obs Norm by SA", "AUMCINF_obs_S", "Plasma/Blood/Serum", "148", |
|
| 13 | -+ | ||
| 162 | +4x |
- #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
+ "AUMCIFOW", "AUMC Infinity Obs Norm by WT", "AUMCINF_obs_W", "Plasma/Blood/Serum", "149", |
|
| 14 | -+ | ||
| 163 | +4x |
- #' pk_ordered_data <- h_pkparam_sort(adpp)+ "AUMCIFPB", "AUMC Infinity Pred Norm by BMI", "AUMCINF_pred_B", "Plasma/Blood/Serum", "150", |
|
| 15 | -+ | ||
| 164 | +4x |
- #'+ "AUMCIFPD", "AUMC Infinity Pred Norm by Dose", "AUMCINF_pred_D", "Plasma/Blood/Serum", "151", |
|
| 16 | -+ | ||
| 165 | +4x |
- #' @export+ "AUMCIFPS", "AUMC Infinity Pred Norm by SA", "AUMCINF_pred_S", "Plasma/Blood/Serum", "152", |
|
| 17 | -+ | ||
| 166 | +4x |
- h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
+ "AUMCIFPW", "AUMC Infinity Pred Norm by WT", "AUMCINF_pred_W", "Plasma/Blood/Serum", "153", |
|
| 18 | +167 | 4x |
- assert_df_with_variables(pk_data, list(key_var = key_var))+ "AUMCLSTB", "AUMC to Last Nonzero Conc Norm by BMI", "AUMClast_B", "Plasma/Blood/Serum", "154", |
| 19 | +168 | 4x |
- pk_data$PARAMCD <- pk_data[[key_var]]+ "AUMCLSTD", "AUMC to Last Nonzero Conc Norm by Dose", "AUMClast_D", "Plasma/Blood/Serum", "155", |
| 20 | -+ | ||
| 169 | +4x |
-
+ "AUMCLSTS", "AUMC to Last Nonzero Conc Norm by SA", "AUMClast_S", "Plasma/Blood/Serum", "156", |
|
| 21 | +170 | 4x |
- ordered_pk_data <- d_pkparam()+ "AUMCLSTW", "AUMC to Last Nonzero Conc Norm by WT", "AUMClast_W", "Plasma/Blood/Serum", "157", |
| 22 | -+ | ||
| 171 | +4x |
-
+ "AUMCTAUB", "AUMC Over Dosing Interval Norm by BMI", "AUMCTAUB", "Plasma/Blood/Serum", "158", |
|
| 23 | -+ | ||
| 172 | +4x |
- # Add the numeric values from ordered_pk_data to pk_data+ "AUMCTAUD", "AUMC Over Dosing Interval Norm by Dose", "AUMCTAUD", "Plasma/Blood/Serum", "159", |
|
| 24 | +173 | 4x |
- joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffixes = c("", ".y"))
+ "AUMCTAUS", "AUMC Over Dosing Interval Norm by SA", "AUMCTAUS", "Plasma/Blood/Serum", "160", |
| 25 | -+ | ||
| 174 | +4x |
-
+ "AUMCTAUW", "AUMC Over Dosing Interval Norm by WT", "AUMCTAUW", "Plasma/Blood/Serum", "161", |
|
| 26 | +175 | 4x |
- joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
+ "AURCALLB", "AURC All Norm by BMI", "AURCALLB", "Plasma/Blood/Serum", "162", |
| 27 | -+ | ||
| 176 | +4x |
-
+ "AURCALLD", "AURC All Norm by Dose", "AURCALLD", "Plasma/Blood/Serum", "163", |
|
| 28 | +177 | 4x |
- joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER)+ "AURCALLS", "AURC All Norm by SA", "AURCALLS", "Plasma/Blood/Serum", "164", |
| 29 | -+ | ||
| 178 | +4x |
-
+ "AURCALLW", "AURC All Norm by WT", "AURCALLW", "Plasma/Blood/Serum", "165", |
|
| 30 | -+ | ||
| 179 | +4x |
- # Then order PARAM based on this column+ "AURCIFOB", "AURC Infinity Obs Norm by BMI", "AURCIFOB", "Plasma/Blood/Serum", "166", |
|
| 31 | +180 | 4x |
- joined_data$PARAM <- factor(joined_data$PARAM,+ "AURCIFOD", "AURC Infinity Obs Norm by Dose", "AURCIFOD", "Plasma/Blood/Serum", "167", |
| 32 | +181 | 4x |
- levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ "AURCIFOS", "AURC Infinity Obs Norm by SA", "AURCIFOS", "Plasma/Blood/Serum", "168", |
| 33 | +182 | 4x |
- ordered = TRUE+ "AURCIFOW", "AURC Infinity Obs Norm by WT", "AURCIFOW", "Plasma/Blood/Serum", "169", |
| 34 | -+ | ||
| 183 | +4x |
- )+ "AURCIFPB", "AURC Infinity Pred Norm by BMI", "AURCIFPB", "Plasma/Blood/Serum", "170", |
|
| 35 | -+ | ||
| 184 | +4x |
-
+ "AURCIFPD", "AURC Infinity Pred Norm by Dose", "AURCIFPD", "Plasma/Blood/Serum", "171", |
|
| 36 | +185 | 4x |
- joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY,+ "AURCIFPS", "AURC Infinity Pred Norm by SA", "AURCIFPS", "Plasma/Blood/Serum", "172", |
| 37 | +186 | 4x |
- levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),+ "AURCIFPW", "AURC Infinity Pred Norm by WT", "AURCIFPW", "Plasma/Blood/Serum", "173", |
| 38 | +187 | 4x |
- ordered = TRUE+ "AURCINT", "AURC from T1 to T2", "AURCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "174", |
| 39 | -+ | ||
| 188 | +4x |
- )+ "AURCINTB", "AURC from T1 to T2 Norm by BMI", "AURCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "175", |
|
| 40 | -+ | ||
| 189 | +4x |
-
+ "AURCINTD", "AURC from T1 to T2 Norm by Dose", "AURCINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "176", |
|
| 41 | +190 | 4x |
- joined_data+ "AURCINTS", "AURC from T1 to T2 Norm by SA", "AURCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "177", |
| 42 | -+ | ||
| 191 | +4x |
- }+ "AURCINTW", "AURC from T1 to T2 Norm by WT", "AURCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "178", |
| 1 | -+ | |||
| 192 | +4x |
- #' Control function for logistic regression model fitting+ "AURCLSTB", "AURC to Last Nonzero Rate Norm by BMI", "AURCLSTB", "Plasma/Blood/Serum", "179", |
||
| 2 | -+ | |||
| 193 | +4x |
- #'+ "AURCLSTD", "AURC to Last Nonzero Rate Norm by Dose", "AURCLSTD", "Plasma/Blood/Serum", "180", |
||
| 3 | -+ | |||
| 194 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ "AURCLSTS", "AURC to Last Nonzero Rate Norm by SA", "AURCLSTS", "Plasma/Blood/Serum", "181", |
||
| 4 | -+ | |||
| 195 | +4x |
- #'+ "AURCLSTW", "AURC to Last Nonzero Rate Norm by WT", "AURCLSTW", "Plasma/Blood/Serum", "182", |
||
| 5 | -+ | |||
| 196 | +4x |
- #' This is an auxiliary function for controlling arguments for logistic regression models.+ "C0B", "Initial Conc Norm by BMI", "C0B", "Plasma/Blood/Serum", "183", |
||
| 6 | -+ | |||
| 197 | +4x |
- #' `conf_level` refers to the confidence level used for the Odds Ratio CIs.+ "C0D", "Initial Conc Norm by Dose", "C0D", "Plasma/Blood/Serum", "184", |
||
| 7 | -+ | |||
| 198 | +4x |
- #'+ "C0S", "Initial Conc Norm by SA", "C0S", "Plasma/Blood/Serum", "185", |
||
| 8 | -+ | |||
| 199 | +4x |
- #' @inheritParams argument_convention+ "C0W", "Initial Conc Norm by WT", "C0W", "Plasma/Blood/Serum", "186", |
||
| 9 | -+ | |||
| 200 | +4x |
- #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ "CAVGB", "Average Conc Norm by BMI", "CAVGB", "Plasma/Blood/Serum", "187", |
||
| 10 | -+ | |||
| 201 | +4x |
- #' This will be used when fitting the logistic regression model on the left hand side of the formula.+ "CAVGD", "Average Conc Norm by Dose", "CAVGD", "Plasma/Blood/Serum", "188", |
||
| 11 | -+ | |||
| 202 | +4x |
- #' Note that the evaluated expression should result in either a logical vector or a factor with 2+ "CAVGINT", "Average Conc from T1 to T2", "CAVGINT_T1_T2_UNIT", "Plasma/Blood/Serum", "189", |
||
| 12 | -+ | |||
| 203 | +4x |
- #' levels. By default this is just `"response"` such that the original response variable is used+ "CAVGINTB", "Average Conc from T1 to T2 Norm by BMI", "CAVGINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "190", |
||
| 13 | -+ | |||
| 204 | +4x |
- #' and not modified further.+ "CAVGINTD", "Average Conc from T1 to T2 Norm by Dose", "CAVGINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "191", |
||
| 14 | -+ | |||
| 205 | +4x |
- #'+ "CAVGINTS", "Average Conc from T1 to T2 Norm by SA", "CAVGINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "192", |
||
| 15 | -+ | |||
| 206 | +4x |
- #' @return A list of components with the same names as the arguments.+ "CAVGINTW", "Average Conc from T1 to T2 Norm by WT", "CAVGINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "193", |
||
| 16 | -+ | |||
| 207 | +4x |
- #'+ "CAVGS", "Average Conc Norm by SA", "CAVGS", "Plasma/Blood/Serum", "194", |
||
| 17 | -+ | |||
| 208 | +4x |
- #' @examples+ "CAVGW", "Average Conc Norm by WT", "CAVGW", "Plasma/Blood/Serum", "195", |
||
| 18 | -+ | |||
| 209 | +4x |
- #' # Standard options.+ "CHTMAX", "Concentration at Half Tmax", "CHTMAX", "Plasma/Blood/Serum", "196", |
||
| 19 | -+ | |||
| 210 | +4x |
- #' control_logistic()+ "CLFOB", "Total CL Obs by F Norm by BMI", "CLFOB", "Plasma/Blood/Serum", "197", |
||
| 20 | -+ | |||
| 211 | +4x |
- #'+ "CLFOD", "Total CL Obs by F Norm by Dose", "CLFOD", "Plasma/Blood/Serum", "198", |
||
| 21 | -+ | |||
| 212 | +4x |
- #' # Modify confidence level.+ "CLFOS", "Total CL Obs by F Norm by SA", "CLFOS", "Plasma/Blood/Serum", "199", |
||
| 22 | -+ | |||
| 213 | +4x |
- #' control_logistic(conf_level = 0.9)+ "CLFOW", "Total CL Obs by F Norm by WT", "CLFOW", "Plasma/Blood/Serum", "200", |
||
| 23 | -+ | |||
| 214 | +4x |
- #'+ "CLFPB", "Total CL Pred by F Norm by BMI", "CLFPB", "Plasma/Blood/Serum", "201", |
||
| 24 | -+ | |||
| 215 | +4x |
- #' # Use a different response definition.+ "CLFPD", "Total CL Pred by F Norm by Dose", "CLFPD", "Plasma/Blood/Serum", "202", |
||
| 25 | -+ | |||
| 216 | +4x |
- #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
+ "CLFPS", "Total CL Pred by F Norm by SA", "CLFPS", "Plasma/Blood/Serum", "203", |
||
| 26 | -+ | |||
| 217 | +4x |
- #'+ "CLFPW", "Total CL Pred by F Norm by WT", "CLFPW", "Plasma/Blood/Serum", "204", |
||
| 27 | -+ | |||
| 218 | +4x |
- #' @export+ "CLFTAU", "Total CL by F for Dose Int", "CLFTAU", "Plasma/Blood/Serum", "205", |
||
| 28 | -+ | |||
| 219 | +4x |
- control_logistic <- function(response_definition = "response",+ "CLFTAUB", "Total CL by F for Dose Int Norm by BMI", "CLFTAUB", "Plasma/Blood/Serum", "206", |
||
| 29 | -+ | |||
| 220 | +4x |
- conf_level = 0.95) {
+ "CLFTAUD", "Total CL by F for Dose Int Norm by Dose", "CLFTAUD", "Plasma/Blood/Serum", "207", |
||
| 30 | -29x | +221 | +4x |
- checkmate::assert_true(grepl("response", response_definition))
+ "CLFTAUS", "Total CL by F for Dose Int Norm by SA", "CLFTAUS", "Plasma/Blood/Serum", "208", |
| 31 | -28x | +222 | +4x |
- checkmate::assert_string(response_definition)+ "CLFTAUW", "Total CL by F for Dose Int Norm by WT", "CLFTAUW", "Plasma/Blood/Serum", "209", |
| 32 | -28x | +223 | +4x |
- assert_proportion_value(conf_level)+ "CLFUB", "Apparent CL for Unbound Drug", "CLFUB", "Plasma/Blood/Serum", "210", |
| 33 | -27x | +224 | +4x |
- list(+ "CLOB", "Total CL Obs Norm by BMI", "CLOB", "Plasma/Blood/Serum", "211", |
| 34 | -27x | +225 | +4x |
- response_definition = response_definition,+ "CLOD", "Total CL Obs Norm by Dose", "CLOD", "Plasma/Blood/Serum", "212", |
| 35 | -27x | +226 | +4x |
- conf_level = conf_level+ "CLOS", "Total CL Obs Norm by SA", "CLOS", "Plasma/Blood/Serum", "213", |
| 36 | -+ | |||
| 227 | +4x |
- )+ "CLOUB", "Total CL Obs for Unbound Drug", "CLOUB", "Plasma/Blood/Serum", "214", |
||
| 37 | -+ | |||
| 228 | +4x |
- }+ "CLOW", "Total CL Obs Norm by WT", "CLOW", "Plasma/Blood/Serum", "215", |
| 1 | -+ | ||
| 229 | +4x |
- #' Generate PK reference dataset+ "CLPB", "Total CL Pred Norm by BMI", "CLPB", "Plasma/Blood/Serum", "216", |
|
| 2 | -+ | ||
| 230 | +4x |
- #'- |
- |
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- |
| 4 | -- |
- #'- |
- |
| 5 | -- |
- #' @return A `data.frame` of PK parameters.- |
- |
| 6 | -- |
- #'- |
- |
| 7 | -- |
- #' @examples- |
- |
| 8 | -- |
- #' pk_reference_dataset <- d_pkparam()- |
- |
| 9 | -- |
- #'- |
- |
| 10 | -- |
- #' @export+ "CLPD", "Total CL Pred Norm by Dose", "CLPD", "Plasma/Blood/Serum", "217", |
|
| 11 | -+ | ||
| 231 | +4x |
- d_pkparam <- function() {
+ "CLPS", "Total CL Pred Norm by SA", "CLPS", "Plasma/Blood/Serum", "218", |
|
| 12 | +232 | 4x |
- pk_dataset <- as.data.frame(matrix(+ "CLPUB", "Total CL Pred for Unbound Drug", "CLPUB", "Plasma/Blood/Serum", "219", |
| 13 | +233 | 4x |
- c(+ "CLPW", "Total CL Pred Norm by WT", "CLPW", "Plasma/Blood/Serum", "220", |
| 14 | +234 | 4x |
- "TMAX", "Time of CMAX", "Tmax", "Plasma/Blood/Serum", "1",+ "CLRPCLEV", "Renal CL as Pct CL EV", "CLRPCLEV", "Urine", "221", |
| 15 | +235 | 4x |
- "CMAX", "Max Conc", "Cmax", "Plasma/Blood/Serum", "2",+ "CLRPCLIV", "Renal CL as Pct CL IV", "CLRPCLIV", "Urine", "222", |
| 16 | +236 | 4x |
- "CMAXD", "Max Conc Norm by Dose", "Cmax/D", "Plasma/Blood/Serum", "3",+ "CLSTB", "Last Nonzero Conc Norm by BMI", "CLSTB", "Plasma/Blood/Serum", "223", |
| 17 | +237 | 4x |
- "AUCIFO", "AUC Infinity Obs", "AUCinf obs", "Plasma/Blood/Serum", "4",+ "CLSTD", "Last Nonzero Conc Norm by Dose", "CLSTD", "Plasma/Blood/Serum", "224", |
| 18 | +238 | 4x |
- "AUCIFP", "AUC Infinity Pred", "AUCinf pred", "Plasma/Blood/Serum", "5",+ "CLSTS", "Last Nonzero Conc Norm by SA", "CLSTS", "Plasma/Blood/Serum", "225", |
| 19 | +239 | 4x |
- "AUCIFOD", "AUC Infinity Obs Norm by Dose", "AUCinf/D obs", "Plasma/Blood/Serum", "6",+ "CLSTW", "Last Nonzero Conc Norm by WT", "CLSTW", "Plasma/Blood/Serum", "226", |
| 20 | +240 | 4x |
- "AUCIFD", "AUC Infinity Pred Norm by Dose", "AUCinf/D pred", "Plasma/Blood/Serum", "7",+ "CLTAU", "Total CL for Dose Int", "CLTAU", "Plasma/Blood/Serum", "227", |
| 21 | +241 | 4x |
- "AUCPEO", "AUC %Extrapolation Obs", "AUCinf extrap obs", "Plasma/Blood/Serum", "8",+ "CLTAUB", "Total CL for Dose Int Norm by BMI", "CLTAUB", "Plasma/Blood/Serum", "228", |
| 22 | +242 | 4x |
- "AUCPEP", "AUC %Extrapolation Pred", "AUCinf extrap pred", "Plasma/Blood/Serum", "9",+ "CLTAUD", "Total CL for Dose Int Norm by Dose", "CLTAUD", "Plasma/Blood/Serum", "229", |
| 23 | +243 | 4x |
- "AUCINT", "AUC from T1 to T2", "AUCupper-lower ", "Plasma/Blood/Serum", "10",+ "CLTAUS", "Total CL for Dose Int Norm by SA", "CLTAUS", "Plasma/Blood/Serum", "230", |
| 24 | +244 | 4x |
- "AUCTAU", "AUC Over Dosing Interval", "AUCtau", "Plasma/Blood/Serum", "11",+ "CLTAUW", "Total CL for Dose Int Norm by WT", "CLTAUW", "Plasma/Blood/Serum", "231", |
| 25 | +245 | 4x |
- "AUCLST", "AUC to Last Nonzero Conc", "AUClast", "Plasma/Blood/Serum", "12",+ "CMAXB", "Max Conc Norm by BMI", "CMAX_B", "Plasma/Blood/Serum", "232", |
| 26 | +246 | 4x |
- "AUCALL", "AUC All", "AUCall", "Plasma/Blood/Serum", "13",+ "CMAXLN", "Max Conc LN Transformed", "CMAXLN", "Plasma/Blood/Serum", "233", |
| 27 | +247 | 4x |
- "AUMCIFO", "AUMC Infinity Obs", "AUMCinf obs", "Plasma/Blood/Serum", "14",+ "CMAXS", "Max Conc Norm by SA", "CMAXS", "Plasma/Blood/Serum", "234", |
| 28 | +248 | 4x |
- "AUMCIFP", "AUMC Infinity Pred", "AUMCinf pred", "Plasma/Blood/Serum", "15",+ "CMAXUB", "Max Conc, Unbound Drug", "CMAXUB", "Plasma/Blood/Serum", "235", |
| 29 | +249 | 4x |
- "AUMCPEO", "AUMC % Extrapolation Obs", "AUMC extrap obs", "Plasma/Blood/Serum", "16",+ "CMAXW", "Max Conc Norm by WT", "CMAXW", "Plasma/Blood/Serum", "236", |
| 30 | +250 | 4x |
- "AUMCPEP", "AUMC % Extrapolation Pred", "AUMC extrap pred", "Plasma/Blood/Serum", "17",+ "CMINB", "Min Conc Norm by BMI", "CMINB", "Plasma/Blood/Serum", "237", |
| 31 | +251 | 4x |
- "AUMCTAU", "AUMC Over Dosing Interval", "AUMCtau", "Plasma/Blood/Serum", "18",+ "CMIND", "Min Conc Norm by Dose", "CMIND", "Plasma/Blood/Serum", "238", |
| 32 | +252 | 4x |
- "AUMCLST", "AUMC to Last Nonzero Conc", "AUMClast", "Plasma/Blood/Serum", "19",+ "CMINS", "Min Conc Norm by SA", "CMINS", "Plasma/Blood/Serum", "239", |
| 33 | +253 | 4x |
- "AURCIFO", "AURC Infinity Obs", "AURCinf obs", "Plasma/Blood/Serum", "20",+ "CMINW", "Min Conc Norm by WT", "CMINW", "Plasma/Blood/Serum", "240", |
| 34 | +254 | 4x |
- "AURCIFP", "AURC Infinity Pred", "AURCinf pred", "Plasma/Blood/Serum", "21",+ "CONC", "Concentration", "CONC", "Plasma/Blood/Serum", "241", |
| 35 | +255 | 4x |
- "AURCPEO", "AURC % Extrapolation Obs", "AURC extrap obs", "Plasma/Blood/Serum", "22",+ "CONCB", "Conc by BMI", "CONCB", "Plasma/Blood/Serum", "242", |
| 36 | +256 | 4x |
- "AURCPEP", "AURC % Extrapolation Pred", "AURC extrap pred", "Plasma/Blood/Serum", "23",+ "CONCD", "Conc by Dose", "CONCD", "Plasma/Blood/Serum", "243", |
| 37 | +257 | 4x |
- "AURCLST", "AURC Dosing to Last Conc", "AURClast", "Plasma/Blood/Serum", "24",+ "CONCS", "Conc by SA", "CONCS", "Plasma/Blood/Serum", "244", |
| 38 | +258 | 4x |
- "AURCALL", "AURC All", "AURCall", "Plasma/Blood/Serum", "25",+ "CONCW", "Conc by WT", "CONCW", "Plasma/Blood/Serum", "245", |
| 39 | +259 | 4x |
- "TLST", "Time of Last Nonzero Conc", "Tlast", "Plasma/Blood/Serum", "26",+ "CTROUGH", "Conc Trough", "CTROUGH", "Plasma/Blood/Serum", "246", |
| 40 | +260 | 4x |
- "CO", "Initial Conc", "CO", "Plasma/Blood/Serum", "27",+ "CTROUGHB", "Conc Trough by BMI", "CTROUGHB", "Plasma/Blood/Serum", "247", |
| 41 | +261 | 4x |
- "C0", "Initial Conc", "C0", "Plasma/Blood/Serum", "28",+ "CTROUGHD", "Conc Trough by Dose", "CTROUGHD", "Plasma/Blood/Serum", "248", |
| 42 | +262 | 4x |
- "CAVG", "Average Conc", "Cavg", "Plasma/Blood/Serum", "29",+ "CTROUGHS", "Conc Trough by SA", "CTROUGHS", "Plasma/Blood/Serum", "249", |
| 43 | +263 | 4x |
- "CLST", "Last Nonzero Conc", "Clast", "Plasma/Blood/Serum", "30",+ "CTROUGHW", "Conc Trough by WT", "CTROUGHW", "Plasma/Blood/Serum", "250", |
| 44 | +264 | 4x |
- "CMIN", "Min Conc", "Cmin", "Plasma/Blood/Serum", "31",+ "EFFHL", "Effective Half-Life", "EFFHL", "Plasma/Blood/Serum", "251", |
| 45 | +265 | 4x |
- "LAMZHL", "Half-Life Lambda z", "t1/2", "Plasma/Blood/Serum", "32",+ "ERINT", "Excret Rate from T1 to T2", "ERINT_T1_T2_UNIT", "Plasma/Blood/Serum", "252", |
| 46 | +266 | 4x |
- "CLFO", "Total CL Obs by F", "CL/F obs", "Plasma/Blood/Serum", "33",+ "ERINTB", "Excret Rate from T1 to T2 Norm by BMI", "ERINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "253", |
| 47 | +267 | 4x |
- "CLFP", "Total CL Pred by F", "CL/F pred", "Plasma/Blood/Serum", "34",+ "ERINTD", "Excret Rate from T1 to T2 Norm by Dose", "ERINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "254", |
| 48 | +268 | 4x |
- "CLO", "Total CL Obs", "CL obs", "Plasma/Blood/Serum", "35",+ "ERINTS", "Excret Rate from T1 to T2 Norm by SA", "ERINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "255", |
| 49 | +269 | 4x |
- "CLP", "Total CL Pred", "CL pred", "Plasma/Blood/Serum", "36",+ "ERINTW", "Excret Rate from T1 to T2 Norm by WT", "ERINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "256", |
| 50 | +270 | 4x |
- "CLSS", "Total CL Steady State Pred", "CLss", "Plasma/Blood/Serum", "37",+ "ERLSTB", "Last Meas Excretion Rate Norm by BMI", "ERLSTB", "Plasma/Blood/Serum", "257", |
| 51 | +271 | 4x |
- "CLSSF", "Total CL Steady State Pred by F", "CLss/F", "Plasma/Blood/Serum", "38",+ "ERLSTD", "Last Meas Excretion Rate Norm by Dose", "ERLSTD", "Plasma/Blood/Serum", "258", |
| 52 | +272 | 4x |
- "VZFO", "Vz Obs by F", "Vz/F obs", "Plasma/Blood/Serum", "39",+ "ERLSTS", "Last Meas Excretion Rate Norm by SA", "ERLSTS", "Plasma/Blood/Serum", "259", |
| 53 | +273 | 4x |
- "VZFP", "Vz Pred by F", "Vz/F pred", "Plasma/Blood/Serum", "40",+ "ERLSTW", "Last Meas Excretion Rate Norm by WT", "ERLSTW", "Plasma/Blood/Serum", "260", |
| 54 | +274 | 4x |
- "VZO", "Vz Obs", "Vz obs", "Plasma/Blood/Serum", "41",+ "ERMAXB", "Max Excretion Rate Norm by BMI", "ERMAXB", "Plasma/Blood/Serum", "261", |
| 55 | +275 | 4x |
- "VZP", "Vz Pred", "Vz pred", "Plasma/Blood/Serum", "42",+ "ERMAXD", "Max Excretion Rate Norm by Dose", "ERMAXD", "Plasma/Blood/Serum", "262", |
| 56 | +276 | 4x |
- "VSSO", "Vol Dist Steady State Obs", "Vss obs", "Plasma/Blood/Serum", "43",+ "ERMAXS", "Max Excretion Rate Norm by SA", "ERMAXS", "Plasma/Blood/Serum", "263", |
| 57 | +277 | 4x |
- "VSSP", "Vol Dist Steady State Pred", "Vss pred", "Plasma/Blood/Serum", "44",+ "ERMAXW", "Max Excretion Rate Norm by WT", "ERMAXW", "Plasma/Blood/Serum", "264", |
| 58 | +278 | 4x |
- "LAMZ", "Lambda z", "Lambda z", "Plasma/Blood/Serum", "45",+ "ERTLST", "Midpoint of Interval of Last Nonzero ER", "ERTLST", "Plasma/Blood/Serum", "265", |
| 59 | +279 | 4x |
- "LAMZLL", "Lambda z Lower Limit", "Lambda z lower", "Plasma/Blood/Serum", "46",+ "FABS", "Absolute Bioavailability", "FABS", "Plasma/Blood/Serum", "266", |
| 60 | +280 | 4x |
- "LAMZUL", "Lambda z Upper Limit", "Lambda z upper", "Plasma/Blood/Serum", "47",+ "FB", "Fraction Bound", "FB", "Plasma/Blood/Serum", "267", |
| 61 | +281 | 4x |
- "LAMZNPT", "Number of Points for Lambda z", "No points Lambda z", "Plasma/Blood/Serum", "48",+ "FREL", "Relative Bioavailability", "FREL", "Plasma/Blood/Serum", "268", |
| 62 | +282 | 4x |
- "MRTIFO", "MRT Infinity Obs", "MRTinf obs", "Plasma/Blood/Serum", "49",+ "FREXINT", "Fract Excr from T1 to T2", "FREXINT_T1_T2_UNIT", "Plasma/Blood/Serum", "269", |
| 63 | +283 | 4x |
- "MRTIFP", "MRT Infinity Pred", "MRTinf pred", "Plasma/Blood/Serum", "50",+ "FU", "Fraction Unbound", "FU", "Plasma/Blood/Serum", "270", |
| 64 | +284 | 4x |
- "MRTLST", "MRT to Last Nonzero Conc", "MRTlast", "Plasma/Blood/Serum", "51",+ "HDCL", "Hemodialysis Clearance", "HDCL", "Plasma/Blood/Serum", "271", |
| 65 | +285 | 4x |
- "R2", "R Squared", "Rsq", "Plasma/Blood/Serum", "52",+ "HDER", "Hemodialysis Extraction Ratio", "HDER", "Plasma/Blood/Serum", "272", |
| 66 | +286 | 4x |
- "R2ADJ", "R Squared Adjusted", "Rsq adjusted", "Plasma/Blood/Serum", "53",+ "HTMAX", "Half Tmax", "HTMAX", "Plasma/Blood/Serum", "273", |
| 67 | +287 | 4x |
- "TLAG", "Time Until First Nonzero Conc", "TIag", "Plasma/Blood/Serum", "54",+ "LAMZLTAU", "Lambda z Lower Limit TAU", "LAMZLTAU", "Plasma/Blood/Serum", "274", |
| 68 | +288 | 4x |
- "TMIN", "Time of CMIN Observation", "Tmin", "Plasma/Blood/Serum", "55",+ "LAMZNTAU", "Number of Points for Lambda z TAU", "LAMZNTAU", "Plasma/Blood/Serum", "275", |
| 69 | +289 | 4x |
- "ACCI", "Accumulation Index", "Accumulation Index", "Plasma/Blood/Serum/Urine", "56",+ "LAMZSPN", "Lambda z Span", "LAMZSPN", "Plasma/Blood/Serum", "276", |
| 70 | +290 | 4x |
- "FLUCP", "Fluctuation%", "Fluctuation", "Plasma/Blood/Serum", "57",+ "LAMZTAU", "Lambda z TAU", "LAMZTAU", "Plasma/Blood/Serum", "277", |
| 71 | +291 | 4x |
- "CORRXY", "Correlation Between TimeX and Log ConcY", "Corr xy", "Plasma/Blood/Serum", "58",+ "LAMZUTAU", "Lambda z Upper Limit TAU", "LAMZUTAU", "Plasma/Blood/Serum", "278", |
| 72 | +292 | 4x |
- "RCAMINT", "Amt Rec from T1 to T2", "Ae", "Urine", "59",+ "MAT", "Mean Absorption Time", "MAT", "Plasma/Blood/Serum", "279", |
| 73 | +293 | 4x |
- "RCPCINT", "Pct Rec from T1 to T2", "Fe", "Urine", "60",+ "MRAUCIFO", "Metabolite Ratio for AUC Infinity Obs", "MRAUCIFO", "Plasma/Blood/Serum", "280", |
| 74 | +294 | 4x |
- "VOLPK", "Sum of Urine Vol", "Urine volume", "Urine", "61",+ "MRAUCIFP", "Metabolite Ratio for AUC Infinity Pred", "MRAUCIFP", "Plasma/Blood/Serum", "281", |
| 75 | +295 | 4x |
- "RENALCL", "Renal CL", "CLR", "Plasma/Blood/Serum/Urine", "62",+ "MRAUCINT", "Metabolite Ratio AUC from T1 to T2", "MRAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "282", |
| 76 | +296 | 4x |
- "ERTMAX", "Time of Max Excretion Rate", "Tmax Rate", "Urine", "63",+ "MRAUCLST", "Metabolite Ratio AUC Last Nonzero Conc", "MRAUCLST", "Plasma/Blood/Serum", "283", |
| 77 | +297 | 4x |
- "RMAX", "Time of Maximum Response", "Rmax", "Matrix of PD", "64",+ "MRAUCTAU", "Metabolite Ratio for AUC Dosing Interval", "MRAUCTAU", "Plasma/Blood/Serum", "284", |
| 78 | +298 | 4x |
- "RMIN", "Time of Minimum Response", "Rmin", "Matrix of PD", "65",+ "MRCMAX", "Metabolite Ratio for Max Conc", "MRCMAX", "Plasma/Blood/Serum", "285", |
| 79 | +299 | 4x |
- "ERMAX", "Max Excretion Rate", "Max excretion rate", "Urine", "66",+ "MRTEVIFO", "MRT Extravasc Infinity Obs", "MRTEVIFO", "Plasma/Blood/Serum", "286", |
| 80 | +300 | 4x |
- "MIDPTLST", "Midpoint of Collection Interval", "Midpoint last", "Urine", "67",+ "MRTEVIFP", "MRT Extravasc Infinity Pred", "MRTEVIFP", "Plasma/Blood/Serum", "287", |
| 81 | +301 | 4x |
- "ERLST", "Last Meas Excretion Rate", "Rate last", "Urine", "68",+ "MRTEVLST", "MRT Extravasc to Last Nonzero Conc", "MRTEVLST", "Plasma/Blood/Serum", "288", |
| 82 | +302 | 4x |
- "TON", "Time to Onset", "Tonset", "Matrix of PD", "69",+ "MRTIVIFO", "MRT Intravasc Infinity Obs", "MRTIVIFO", "Plasma/Blood/Serum", "289", |
| 83 | +303 | 4x |
- "TOFF", "Time to Offset", "Toffset", "Matrix of PD", "70",+ "MRTIVIFP", "MRT Intravasc Infinity Pred", "MRTIVIFP", "Plasma/Blood/Serum", "290", |
| 84 | +304 | 4x |
- "TBBLP", "Time Below Baseline %", "Time %Below Baseline", "Matrix of PD", "71",+ "MRTIVLST", "MRT Intravasc to Last Nonzero Conc", "MRTIVLST", "Plasma/Blood/Serum", "291", |
| 85 | +305 | 4x |
- "TBTP", "Time Below Threshold %", "Time %Below Threshold", "Matrix of PD", "72",+ "NRENALCL", "Nonrenal CL", "NRENALCL", "Urine", "292", |
| 86 | +306 | 4x |
- "TABL", "Time Above Baseline", "Time Above Baseline", "Matrix of PD", "73",+ "NRENLCLB", "Nonrenal CL Norm by BMI", "NRENLCLB", "Urine", "293", |
| 87 | +307 | 4x |
- "TAT", "Time Above Threshold", "Time Above Threshold", "Matrix of PD", "74",+ "NRENLCLD", "Nonrenal CL Norm by Dose", "NRENLCLD", "Urine", "294", |
| 88 | +308 | 4x |
- "TBT", "Time Below Threshold", "Time Below Threshold", "Matrix of PD", "75",+ "NRENLCLS", "Nonrenal CL Norm by SA", "NRENLCLS", "Urine", "295", |
| 89 | +309 | 4x |
- "TBLT", "Time Between Baseline and Threshold", "Time Between Baseline Threshold", "Matrix of PD", "76",+ "NRENLCLW", "Nonrenal CL Norm by WT", "NRENLCLW", "Urine", "296", |
| 90 | +310 | 4x |
- "BLRSP", "Baseline Response", "Baseline", "Matrix of PD", "77",+ "PTROUGHR", "Peak Trough Ratio", "PTROUGHR", "Plasma/Blood/Serum", "297", |
| 91 | +311 | 4x |
- "TSHDRSP", "Response Threshold", "Threshold", "Matrix of PD", "78",+ "RAAUC", "Ratio AUC", "RAAUC", "Plasma/Blood/Serum", "298", |
| 92 | +312 | 4x |
- "AUCABL", "AUC Above Baseline", "AUC above baseline", "Matrix of PD", "79",+ "RAAUCIFO", "Ratio AUC Infinity Obs", "RAAUCIFO", "Plasma/Blood/Serum", "299", |
| 93 | +313 | 4x |
- "AUCAT", "AUC Above Threshold", "AUC above threshold", "Matrix of PD", "80",+ "RAAUCIFP", "Ratio AUC Infinity Pred", "RAAUCIFP", "Plasma/Blood/Serum", "300", |
| 94 | +314 | 4x |
- "AUCBBL", "AUC Below Baseline", "AUC below baseline", "Matrix of PD", "81",+ "RACMAX", "Ratio CMAX", "RACMAX", "Plasma/Blood/Serum", "301", |
| 95 | +315 | 4x |
- "AUCBT", "AUC Below Threshold", "AUC below threshold", "Matrix of PD", "82",+ "RAMAXMIN", "Ratio of CMAX to CMIN", "RAMAXMIN", "Plasma/Blood/Serum", "302", |
| 96 | +316 | 4x |
- "AUCBLDIF", "Diff AUC Above Base and AUC Below Base", "AUC diff baseline", "Matrix of PD", "83",+ "RCAMIFO", "Amt Rec Infinity Obs", "RCAMIFO", "Plasma/Blood/Serum", "303", |
| 97 | +317 | 4x |
- "AUCTDIF", "Diff AUC Above Thr and AUC Below Thr", "AUCnet threshold", "Matrix of PD", "84",+ "RCAMIFOB", "Amt Rec Infinity Obs Norm by BMI", "RCAMIFOB", "Plasma/Blood/Serum", "304", |
| 98 | +318 | 4x |
- "TDIFF", "Diff Time to Offset and Time to Onset", "Diff toffset-tonset", "Matrix of PD", "85",+ "RCAMIFOS", "Amt Rec Infinity Obs Norm by SA", "RCAMIFOS", "Plasma/Blood/Serum", "305", |
| 99 | +319 | 4x |
- "AUCPBEO", "AUC %Back Extrapolation Obs", "AUC%Back extrap obs", "Plasma/Blood/Serum", "86",+ "RCAMIFOW", "Amt Rec Infinity Obs Norm by WT", "RCAMIFOW", "Plasma/Blood/Serum", "306", |
| 100 | +320 | 4x |
- "AUCPBEP", "AUC %Back Extrapolation Pred", "AUC%Back extrap pred", "Plasma/Blood/Serum", "87",+ "RCAMIFP", "Amt Rec Infinity Pred", "RCAMIFP", "Plasma/Blood/Serum", "307", |
| 101 | +321 | 4x |
- "TSLP1L", "Lower Time Limit Slope 1st", "Slope1 lower", "Matrix of PD", "88",+ "RCAMIFPB", "Amt Rec Infinity Pred Norm by BMI", "RCAMIFPB", "Plasma/Blood/Serum", "308", |
| 102 | +322 | 4x |
- "TSLP1U", "Upper Time Limit Slope 1st Segment", "Slope1 upper", "Matrix of PD", "89",+ "RCAMIFPS", "Amt Rec Infinity Pred Norm by SA", "RCAMIFPS", "Plasma/Blood/Serum", "309", |
| 103 | +323 | 4x |
- "TSLP2L", "Lower Time Limit Slope 2nd Segment", "Slope2 lower", "Matrix of PD", "90",+ "RCAMIFPW", "Amt Rec Infinity Pred Norm by WT", "RCAMIFPW", "Plasma/Blood/Serum", "310", |
| 104 | +324 | 4x |
- "TSLP2U", "Upper Time Limit Slope 2nd Segment", "Slope2 upper", "Matrix of PD", "91",+ "RCAMINTB", "Amt Rec from T1 to T2 Norm by BMI", "RCAMINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "311", |
| 105 | +325 | 4x |
- "SLP1", "Slope, 1st Segment", "Slope1", "Matrix of PD", "92",+ "RCAMINTS", "Amt Rec from T1 to T2 Norm by SA", "RCAMINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "312", |
| 106 | +326 | 4x |
- "SLP2", "Slope, 2nd Segment", "Slope2", "Matrix of PD", "93",+ "RCAMINTW", "Amt Rec from T1 to T2 Norm by WT", "RCAMINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "313", |
| 107 | +327 | 4x |
- "SLP1PT", "Number of Points for Slope 1st Segment", "No points slope1", "Matrix of PD", "94",+ "RCAMTAU", "Amt Rec Over Dosing Interval", "RCAMTAU", "Plasma/Blood/Serum", "314", |
| 108 | +328 | 4x |
- "SLP2PT", "Number of Points for Slope 2nd Segment", "No points slope2", "Matrix of PD", "95",+ "RCAMTAUB", "Amt Rec Over Dosing Interval Norm by BMI", "RCAMTAUB", "Plasma/Blood/Serum", "315", |
| 109 | +329 | 4x |
- "R2ADJS1", "R-Squared Adjusted Slope, 1st Segment", "Rsq adjusted slope1", "Matrix of PD", "96",+ "RCAMTAUS", "Amt Rec Over Dosing Interval Norm by SA", "RCAMTAUS", "Plasma/Blood/Serum", "316", |
| 110 | +330 | 4x |
- "R2ADJS2", "R-Squared Adjusted Slope, 2nd Segment", "Rsq adjusted slope2", "Matrix of PD", "97",+ "RCAMTAUW", "Amt Rec Over Dosing Interval Norm by WT", "RCAMTAUW", "Plasma/Blood/Serum", "317", |
| 111 | +331 | 4x |
- "R2SLP1", "R Squared, Slope, 1st Segment", "Rsq slope1", "Matrix of PD", "98",+ "RCPCIFO", "Pct Rec Infinity Obs", "RCPCIFO", "Plasma/Blood/Serum", "318", |
| 112 | +332 | 4x |
- "R2SLP2", "R Squared, Slope, 2nd Segment", "Rsq slope2", "Matrix of PD", "99",+ "RCPCIFOB", "Pct Rec Infinity Obs Norm by BMI", "RCPCIFOB", "Plasma/Blood/Serum", "319", |
| 113 | +333 | 4x |
- "CORRXYS1", "Corr Btw TimeX and Log ConcY, Slope 1st", "Corr xy slope1", "Plasma/Blood/Serum", "100",+ "RCPCIFOS", "Pct Rec Infinity Obs Norm by SA", "RCPCIFOS", "Plasma/Blood/Serum", "320", |
| 114 | +334 | 4x |
- "CORRXYS2", "Corr Btw TimeX and Log ConcY, Slope 1st Slope 2nd", "Corr xy slope2", "Plasma/Blood/Serum", "101",+ "RCPCIFOW", "Pct Rec Infinity Obs Norm by WT", "RCPCIFOW", "Plasma/Blood/Serum", "321", |
| 115 | +335 | 4x |
- "AILAMZ", "Accumulation Index using Lambda z", "AILAMZ", "Plasma/Blood/Serum", "102",+ "RCPCIFP", "Pct Rec Infinity Pred", "RCPCIFP", "Plasma/Blood/Serum", "322", |
| 116 | +336 | 4x |
- "ARAUC", "Accumulation Ratio AUCTAU", "ARAUC", "Plasma/Blood/Serum", "103",+ "RCPCIFPB", "Pct Rec Infinity Pred Norm by BMI", "RCPCIFPB", "Plasma/Blood/Serum", "323", |
| 117 | +337 | 4x |
- "ARAUCD", "Accum Ratio AUCTAU norm by dose", "ARAUCD", "Plasma/Blood/Serum", "104",+ "RCPCIFPS", "Pct Rec Infinity Pred Norm by SA", "RCPCIFPS", "Plasma/Blood/Serum", "324", |
| 118 | +338 | 4x |
- "ARAUCIFO", "Accum Ratio AUC Infinity Obs", "ARAUCIFO", "Plasma/Blood/Serum", "105",+ "RCPCIFPW", "Pct Rec Infinity Pred Norm by WT", "RCPCIFPW", "Plasma/Blood/Serum", "325", |
| 119 | +339 | 4x |
- "ARAUCIFP", "Accum Ratio AUC Infinity Pred", "ARAUCIFP", "Plasma/Blood/Serum", "106",+ "RCPCINTB", "Pct Rec from T1 to T2 Norm by BMI", "RCPCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "326", |
| 120 | +340 | 4x |
- "ARAUCIND", "Accum Ratio AUC T1 to T2 norm by dose", "ARAUCIND_T1_T2_UNIT", "Plasma/Blood/Serum", "107",+ "RCPCINTS", "Pct Rec from T1 to T2 Norm by SA", "RCPCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "327", |
| 121 | +341 | 4x |
- "ARAUCINT", "Accumulation Ratio AUC from T1 to T2", "ARAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "108",+ "RCPCINTW", "Pct Rec from T1 to T2 Norm by WT", "RCPCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "328", |
| 122 | +342 | 4x |
- "ARAUCIOD", "Accum Ratio AUCIFO Norm by Dose", "ARAUCIOD", "Plasma/Blood/Serum", "109",+ "RCPCLST", "Pct Rec to Last Nonzero Conc", "RCPCLST", "Plasma/Blood/Serum", "329", |
| 123 | +343 | 4x |
- "ARAUCIPD", "Accum Ratio AUCIFP Norm by Dose", "ARAUCIPD", "Plasma/Blood/Serum", "110",+ "RCPCTAU", "Pct Rec Over Dosing Interval", "RCPCTAU", "Plasma/Blood/Serum", "330", |
| 124 | +344 | 4x |
- "ARAUCLST", "Accum Ratio AUC to Last Nonzero Conc", "ARAUCLST", "Plasma/Blood/Serum", "111",+ "RCPCTAUB", "Pct Rec Over Dosing Interval Norm by BMI", "RCPCTAUB", "Plasma/Blood/Serum", "331", |
| 125 | +345 | 4x |
- "ARCMAX", "Accumulation Ratio Cmax", "ARCMAX", "Plasma/Blood/Serum", "112",+ "RCPCTAUS", "Pct Rec Over Dosing Interval Norm by SA", "RCPCTAUS", "Plasma/Blood/Serum", "332", |
| 126 | +346 | 4x |
- "ARCMAXD", "Accum Ratio Cmax norm by dose", "ARCMAXD", "Plasma/Blood/Serum", "113",+ "RCPCTAUW", "Pct Rec Over Dosing Interval Norm by WT", "RCPCTAUW", "Plasma/Blood/Serum", "333", |
| 127 | +347 | 4x |
- "ARCMIN", "Accumulation Ratio Cmin", "ARCMIN", "Plasma/Blood/Serum", "114",+ "RENALCLB", "Renal CL Norm by BMI", "RENALCLB", "Urine", "334", |
| 128 | +348 | 4x |
- "ARCMIND", "Accum Ratio Cmin norm by dose", "ARCMIND", "Plasma/Blood/Serum", "115",+ "RENALCLD", "Renal CL Norm by Dose", "RENALCLD", "Urine", "335", |
| 129 | +349 | 4x |
- "ARCTROUD", "Accum Ratio Ctrough norm by dose", "ARCTROUD", "Plasma/Blood/Serum", "116",+ "RENALCLS", "Renal CL Norm by SA", "RENALCLS", "Urine", "336", |
| 130 | +350 | 4x |
- "ARCTROUG", "Accumulation Ratio Ctrough", "ARCTROUG", "Plasma/Blood/Serum", "117",+ "RENALCLW", "Renal CL Norm by WT", "RENALCLW", "Urine", "337", |
| 131 | +351 | 4x |
- "AUCALLB", "AUC All Norm by BMI", "AUCall_B", "Plasma/Blood/Serum", "118",+ "RENCLTAU", "Renal CL for Dose Int", "RENCLTAU", "Urine", "338", |
| 132 | +352 | 4x |
- "AUCALLD", "AUC All Norm by Dose", "AUCall_D", "Plasma/Blood/Serum", "119",+ "RNCLINT", "Renal CL from T1 to T2", "RNCLINT_T1_T2_UNIT", "Urine", "339", |
| 133 | +353 | 4x |
- "AUCALLS", "AUC All Norm by SA", "AUCall_S", "Plasma/Blood/Serum", "120",+ "RNCLINTB", "Renal CL from T1 to T2 Norm by BMI", "RNCLINTB_T1_T2_UNIT", "Urine", "340", |
| 134 | +354 | 4x |
- "AUCALLW", "AUC All Norm by WT", "AUCall_W", "Plasma/Blood/Serum", "121",+ "RNCLINTD", "Renal CL from T1 to T2 Norm by Dose", "RNCLINTD_T1_T2_UNIT", "Urine", "341", |
| 135 | +355 | 4x |
- "AUCIFOB", "AUC Infinity Obs Norm by BMI", "AUCINF_obs_B", "Plasma/Blood/Serum", "122",+ "RNCLINTS", "Renal CL from T1 to T2 Norm by SA", "RNCLINTS_T1_T2_UNIT", "Urine", "342", |
| 136 | +356 | 4x |
- "AUCIFOLN", "AUC Infinity Obs LN Transformed", "AUCIFOLN", "Plasma/Blood/Serum", "123",+ "RNCLINTW", "Renal CL from T1 to T2 Norm by WT", "RNCLINTW_T1_T2_UNIT", "Urine", "343", |
| 137 | +357 | 4x |
- "AUCIFOS", "AUC Infinity Obs Norm by SA", "AUCINF_obs_S", "Plasma/Blood/Serum", "124",+ "RNCLTAUB", "Renal CL for Dose Int Norm by BMI", "RNCLTAUB", "Urine", "344", |
| 138 | +358 | 4x |
- "AUCIFOUB", "AUC Infinity Obs, Unbound Drug", "AUCIFOUB", "Plasma/Blood/Serum", "125",+ "RNCLTAUD", "Renal CL for Dose Int Norm by Dose", "RNCLTAUD", "Urine", "345", |
| 139 | +359 | 4x |
- "AUCIFOW", "AUC Infinity Obs Norm by WT", "AUCINF_obs_W", "Plasma/Blood/Serum", "126",+ "RNCLTAUS", "Renal CL for Dose Int Norm by SA", "RNCLTAUS", "Urine", "346", |
| 140 | +360 | 4x |
- "AUCIFPB", "AUC Infinity Pred Norm by BMI", "AUCINF_pred_B", "Plasma/Blood/Serum", "127",+ "RNCLTAUW", "Renal CL for Dose Int Norm by WT", "RNCLTAUW", "Urine", "347", |
| 141 | +361 | 4x |
- "AUCIFPD", "AUC Infinity Pred Norm by Dose", "AUCINF_pred_D", "Plasma/Blood/Serum", "128",+ "RNCLUB", "Renal CL for Unbound Drug", "RNCLUB", "Urine", "348", |
| 142 | +362 | 4x |
- "AUCIFPS", "AUC Infinity Pred Norm by SA", "AUCINF_pred_S", "Plasma/Blood/Serum", "129",+ "SRAUC", "Stationarity Ratio AUC", "SRAUC", "Plasma/Blood/Serum", "349", |
| 143 | +363 | 4x |
- "AUCIFPUB", "AUC Infinity Pred, Unbound Drug", "AUCIFPUB", "Plasma/Blood/Serum", "130",+ "SWING", "Swing", "SWING", "Plasma/Blood/Serum", "350", |
| 144 | +364 | 4x |
- "AUCIFPW", "AUC Infinity Pred Norm by WT", "AUCINF_pred_W", "Plasma/Blood/Serum", "131",+ "TAUHL", "Half-Life TAU", "TAUHL", "Plasma/Blood/Serum", "351", |
| 145 | +365 | 4x |
- "AUCINTB", "AUC from T1 to T2 Norm by BMI", "AUC_B_T1_T2_UNIT", "Plasma/Blood/Serum", "132",+ "TBBL", "Time Below Baseline", "Time_Below_B", "Plasma/Blood/Serum", "352", |
| 146 | +366 | 4x |
- "AUCINTD", "AUC from T1 to T2 Norm by Dose", "AUC_D_T1_T2_UNIT", "Plasma/Blood/Serum", "133",+ "TROUGHPR", "Trough Peak Ratio", "TROUGHPR", "Plasma/Blood/Serum", "353", |
| 147 | +367 | 4x |
- "AUCINTS", "AUC from T1 to T2 Norm by SA", "AUC_S_T1_T2_UNIT", "Plasma/Blood/Serum", "134",+ "V0", "Vol Dist Initial", "V0", "Plasma/Blood/Serum", "354", |
| 148 | +368 | 4x |
- "AUCINTW", "AUC from T1 to T2 Norm by WT", "AUC_W_T1_T2_UNIT", "Plasma/Blood/Serum", "135",+ "V0B", "Vol Dist Initial Norm by BMI", "V0B", "Plasma/Blood/Serum", "355", |
| 149 | +369 | 4x |
- "AUCLSTB", "AUC to Last Nonzero Conc Norm by BMI", "AUClast_B", "Plasma/Blood/Serum", "136",+ "V0D", "Vol Dist Initial Norm by Dose", "V0D", "Plasma/Blood/Serum", "356", |
| 150 | +370 | 4x |
- "AUCLSTD", "AUC to Last Nonzero Conc Norm by Dose", "AUClast_D", "Plasma/Blood/Serum", "137",+ "V0S", "Vol Dist Initial Norm by SA", "V0S", "Plasma/Blood/Serum", "357", |
| 151 | +371 | 4x |
- "AUCLSTLN", "AUC to Last Nonzero Conc LN Transformed", "AUCLSTLN", "Plasma/Blood/Serum", "138",+ "V0W", "Vol Dist Initial Norm by WT", "V0W", "Plasma/Blood/Serum", "358", |
| 152 | +372 | 4x |
- "AUCLSTS", "AUC to Last Nonzero Conc Norm by SA", "AUClast_S", "Plasma/Blood/Serum", "139",+ "VSSOB", "Vol Dist Steady State Obs Norm by BMI", "VSSOB", "Plasma/Blood/Serum", "359", |
| 153 | +373 | 4x |
- "AUCLSTUB", "AUC to Last Nonzero Conc, Unbound Drug", "AUCLSTUB", "Plasma/Blood/Serum", "140",+ "VSSOBD", "Vol Dist Steady State Obs by B", "VSSOBD", "Plasma/Blood/Serum", "360", |
| 154 | +374 | 4x |
- "AUCLSTW", "AUC to Last Nonzero Conc Norm by WT", "AUClast_W", "Plasma/Blood/Serum", "141",+ "VSSOD", "Vol Dist Steady State Obs Norm by Dose", "VSSOD", "Plasma/Blood/Serum", "361", |
| 155 | +375 | 4x |
- "AUCTAUB", "AUC Over Dosing Interval Norm by BMI", "AUC_TAU_B", "Plasma/Blood/Serum", "142",+ "VSSOF", "Vol Dist Steady State Obs by F", "VSSOF", "Plasma/Blood/Serum", "362", |
| 156 | +376 | 4x |
- "AUCTAUD", "AUC Over Dosing Interval Norm by Dose", "AUC_TAU_D", "Plasma/Blood/Serum", "143",+ "VSSOS", "Vol Dist Steady State Obs Norm by SA", "VSSOS", "Plasma/Blood/Serum", "363", |
| 157 | +377 | 4x |
- "AUCTAUS", "AUC Over Dosing Interval Norm by SA", "AUC_TAU_S", "Plasma/Blood/Serum", "144",+ "VSSOUB", "Vol Dist Steady State Obs by UB", "VSSOUB", "Plasma/Blood/Serum", "364", |
| 158 | +378 | 4x |
- "AUCTAUW", "AUC Over Dosing Interval Norm by WT", "AUC_TAU_W", "Plasma/Blood/Serum", "145",+ "VSSOW", "Vol Dist Steady State Obs Norm by WT", "VSSOW", "Plasma/Blood/Serum", "365", |
| 159 | +379 | 4x |
- "AUMCIFOB", "AUMC Infinity Obs Norm by BMI", "AUMCINF_obs_B", "Plasma/Blood/Serum", "146",+ "VSSPB", "Vol Dist Steady State Pred Norm by BMI", "VSSPB", "Plasma/Blood/Serum", "366", |
| 160 | +380 | 4x |
- "AUMCIFOD", "AUMC Infinity Obs Norm by Dose", "AUMCINF_obs_D", "Plasma/Blood/Serum", "147",+ "VSSPBD", "Vol Dist Steady State Pred by B", "VSSPBD", "Plasma/Blood/Serum", "367", |
| 161 | +381 | 4x |
- "AUMCIFOS", "AUMC Infinity Obs Norm by SA", "AUMCINF_obs_S", "Plasma/Blood/Serum", "148",+ "VSSPD", "Vol Dist Steady State Pred Norm by Dose", "VSSPD", "Plasma/Blood/Serum", "368", |
| 162 | +382 | 4x |
- "AUMCIFOW", "AUMC Infinity Obs Norm by WT", "AUMCINF_obs_W", "Plasma/Blood/Serum", "149",+ "VSSPF", "Vol Dist Steady State Pred by F", "VSSPF", "Plasma/Blood/Serum", "369", |
| 163 | +383 | 4x |
- "AUMCIFPB", "AUMC Infinity Pred Norm by BMI", "AUMCINF_pred_B", "Plasma/Blood/Serum", "150",+ "VSSPS", "Vol Dist Steady State Pred Norm by SA", "VSSPS", "Plasma/Blood/Serum", "370", |
| 164 | +384 | 4x |
- "AUMCIFPD", "AUMC Infinity Pred Norm by Dose", "AUMCINF_pred_D", "Plasma/Blood/Serum", "151",+ "VSSPUB", "Vol Dist Steady State Pred by UB", "VSSPUB", "Plasma/Blood/Serum", "371", |
| 165 | +385 | 4x |
- "AUMCIFPS", "AUMC Infinity Pred Norm by SA", "AUMCINF_pred_S", "Plasma/Blood/Serum", "152",+ "VSSPW", "Vol Dist Steady State Pred Norm by WT", "VSSPW", "Plasma/Blood/Serum", "372", |
| 166 | +386 | 4x |
- "AUMCIFPW", "AUMC Infinity Pred Norm by WT", "AUMCINF_pred_W", "Plasma/Blood/Serum", "153",+ "VZ", "Vol Z", "Vz", "Plasma/Blood/Serum", "373", |
| 167 | +387 | 4x |
- "AUMCLSTB", "AUMC to Last Nonzero Conc Norm by BMI", "AUMClast_B", "Plasma/Blood/Serum", "154",+ "VZF", "Vol Z by F", "Vz_F", "Plasma/Blood/Serum", "374", |
| 168 | +388 | 4x |
- "AUMCLSTD", "AUMC to Last Nonzero Conc Norm by Dose", "AUMClast_D", "Plasma/Blood/Serum", "155",+ "VZFOB", "Vz Obs by F Norm by BMI", "VZFOB", "Plasma/Blood/Serum", "375", |
| 169 | +389 | 4x |
- "AUMCLSTS", "AUMC to Last Nonzero Conc Norm by SA", "AUMClast_S", "Plasma/Blood/Serum", "156",+ "VZFOD", "Vz Obs by F Norm by Dose", "VZFOD", "Plasma/Blood/Serum", "376", |
| 170 | +390 | 4x |
- "AUMCLSTW", "AUMC to Last Nonzero Conc Norm by WT", "AUMClast_W", "Plasma/Blood/Serum", "157",+ "VZFOS", "Vz Obs by F Norm by SA", "VZFOS", "Plasma/Blood/Serum", "377", |
| 171 | +391 | 4x |
- "AUMCTAUB", "AUMC Over Dosing Interval Norm by BMI", "AUMCTAUB", "Plasma/Blood/Serum", "158",+ "VZFOUB", "Vz Obs by F for UB", "VZFOUB", "Plasma/Blood/Serum", "378", |
| 172 | +392 | 4x |
- "AUMCTAUD", "AUMC Over Dosing Interval Norm by Dose", "AUMCTAUD", "Plasma/Blood/Serum", "159",+ "VZFOW", "Vz Obs by F Norm by WT", "VZFOW", "Plasma/Blood/Serum", "379", |
| 173 | +393 | 4x |
- "AUMCTAUS", "AUMC Over Dosing Interval Norm by SA", "AUMCTAUS", "Plasma/Blood/Serum", "160",+ "VZFPB", "Vz Pred by F Norm by BMI", "VZFPB", "Plasma/Blood/Serum", "380", |
| 174 | +394 | 4x |
- "AUMCTAUW", "AUMC Over Dosing Interval Norm by WT", "AUMCTAUW", "Plasma/Blood/Serum", "161",+ "VZFPD", "Vz Pred by F Norm by Dose", "VZFPD", "Plasma/Blood/Serum", "381", |
| 175 | +395 | 4x |
- "AURCALLB", "AURC All Norm by BMI", "AURCALLB", "Plasma/Blood/Serum", "162",+ "VZFPS", "Vz Pred by F Norm by SA", "VZFPS", "Plasma/Blood/Serum", "382", |
| 176 | +396 | 4x |
- "AURCALLD", "AURC All Norm by Dose", "AURCALLD", "Plasma/Blood/Serum", "163",+ "VZFPUB", "Vz Pred by F for UB", "VZFPUB", "Plasma/Blood/Serum", "383", |
| 177 | +397 | 4x |
- "AURCALLS", "AURC All Norm by SA", "AURCALLS", "Plasma/Blood/Serum", "164",+ "VZFPW", "Vz Pred by F Norm by WT", "VZFPW", "Plasma/Blood/Serum", "384", |
| 178 | +398 | 4x |
- "AURCALLW", "AURC All Norm by WT", "AURCALLW", "Plasma/Blood/Serum", "165",+ "VZFTAU", "Vz for Dose Int by F", "VZFTAU", "Plasma/Blood/Serum", "385", |
| 179 | +399 | 4x |
- "AURCIFOB", "AURC Infinity Obs Norm by BMI", "AURCIFOB", "Plasma/Blood/Serum", "166",+ "VZFTAUB", "Vz for Dose Int by F Norm by BMI", "VZFTAUB", "Plasma/Blood/Serum", "386", |
| 180 | +400 | 4x |
- "AURCIFOD", "AURC Infinity Obs Norm by Dose", "AURCIFOD", "Plasma/Blood/Serum", "167",+ "VZFTAUD", "Vz for Dose Int by F Norm by Dose", "VZFTAUD", "Plasma/Blood/Serum", "387", |
| 181 | +401 | 4x |
- "AURCIFOS", "AURC Infinity Obs Norm by SA", "AURCIFOS", "Plasma/Blood/Serum", "168",+ "VZFTAUS", "Vz for Dose Int by F Norm by SA", "VZFTAUS", "Plasma/Blood/Serum", "388", |
| 182 | +402 | 4x |
- "AURCIFOW", "AURC Infinity Obs Norm by WT", "AURCIFOW", "Plasma/Blood/Serum", "169",+ "VZFTAUW", "Vz for Dose Int by F Norm by WT", "VZFTAUW", "Plasma/Blood/Serum", "389", |
| 183 | +403 | 4x |
- "AURCIFPB", "AURC Infinity Pred Norm by BMI", "AURCIFPB", "Plasma/Blood/Serum", "170",+ "VZOB", "Vz Obs Norm by BMI", "VZOB", "Plasma/Blood/Serum", "390", |
| 184 | +404 | 4x |
- "AURCIFPD", "AURC Infinity Pred Norm by Dose", "AURCIFPD", "Plasma/Blood/Serum", "171",+ "VZOD", "Vz Obs Norm by Dose", "VZOD", "Plasma/Blood/Serum", "391", |
| 185 | +405 | 4x |
- "AURCIFPS", "AURC Infinity Pred Norm by SA", "AURCIFPS", "Plasma/Blood/Serum", "172",+ "VZOS", "Vz Obs Norm by SA", "VZOS", "Plasma/Blood/Serum", "392", |
| 186 | +406 | 4x |
- "AURCIFPW", "AURC Infinity Pred Norm by WT", "AURCIFPW", "Plasma/Blood/Serum", "173",+ "VZOUB", "Vz Obs for UB", "VZOUB", "Plasma/Blood/Serum", "393", |
| 187 | +407 | 4x |
- "AURCINT", "AURC from T1 to T2", "AURCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "174",+ "VZOW", "Vz Obs Norm by WT", "VZOW", "Plasma/Blood/Serum", "394", |
| 188 | +408 | 4x |
- "AURCINTB", "AURC from T1 to T2 Norm by BMI", "AURCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "175",+ "VZPB", "Vz Pred Norm by BMI", "VZPB", "Plasma/Blood/Serum", "395", |
| 189 | +409 | 4x |
- "AURCINTD", "AURC from T1 to T2 Norm by Dose", "AURCINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "176",+ "VZPD", "Vz Pred Norm by Dose", "VZPD", "Plasma/Blood/Serum", "396", |
| 190 | +410 | 4x |
- "AURCINTS", "AURC from T1 to T2 Norm by SA", "AURCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "177",+ "VZPS", "Vz Pred Norm by SA", "VZPS", "Plasma/Blood/Serum", "397", |
| 191 | +411 | 4x |
- "AURCINTW", "AURC from T1 to T2 Norm by WT", "AURCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "178",+ "VZPUB", "Vz Pred for UB", "VZPUB", "Plasma/Blood/Serum", "398" |
| 192 | -4x | +||
| 412 | +
- "AURCLSTB", "AURC to Last Nonzero Rate Norm by BMI", "AURCLSTB", "Plasma/Blood/Serum", "179",+ ), |
||
| 193 | +413 | 4x |
- "AURCLSTD", "AURC to Last Nonzero Rate Norm by Dose", "AURCLSTD", "Plasma/Blood/Serum", "180",+ ncol = 5, |
| 194 | +414 | 4x |
- "AURCLSTS", "AURC to Last Nonzero Rate Norm by SA", "AURCLSTS", "Plasma/Blood/Serum", "181",+ byrow = TRUE |
| 195 | -4x | +||
| 415 | +
- "AURCLSTW", "AURC to Last Nonzero Rate Norm by WT", "AURCLSTW", "Plasma/Blood/Serum", "182",+ )) |
||
| 196 | +416 | 4x |
- "C0B", "Initial Conc Norm by BMI", "C0B", "Plasma/Blood/Serum", "183",+ colnames(pk_dataset) <- c("PARAMCD", "PARAM", "TLG_DISPLAY", "MATRIX", "TLG_ORDER")
|
| 197 | +417 | 4x |
- "C0D", "Initial Conc Norm by Dose", "C0D", "Plasma/Blood/Serum", "184",+ pk_dataset |
| 198 | -4x | +||
| 418 | +
- "C0S", "Initial Conc Norm by SA", "C0S", "Plasma/Blood/Serum", "185",+ } |
||
| 199 | -4x | +
| 1 | +
- "C0W", "Initial Conc Norm by WT", "C0W", "Plasma/Blood/Serum", "186",+ #' Control function for incidence rate |
|||
| 200 | -4x | +|||
| 2 | +
- "CAVGB", "Average Conc Norm by BMI", "CAVGB", "Plasma/Blood/Serum", "187",+ #' |
|||
| 201 | -4x | +|||
| 3 | +
- "CAVGD", "Average Conc Norm by Dose", "CAVGD", "Plasma/Blood/Serum", "188",+ #' @description `r lifecycle::badge("stable")`
|
|||
| 202 | -4x | +|||
| 4 | +
- "CAVGINT", "Average Conc from T1 to T2", "CAVGINT_T1_T2_UNIT", "Plasma/Blood/Serum", "189",+ #' |
|||
| 203 | -4x | +|||
| 5 | +
- "CAVGINTB", "Average Conc from T1 to T2 Norm by BMI", "CAVGINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "190",+ #' This is an auxiliary function for controlling arguments for the incidence rate, used |
|||
| 204 | -4x | +|||
| 6 | +
- "CAVGINTD", "Average Conc from T1 to T2 Norm by Dose", "CAVGINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "191",+ #' internally to specify details in `s_incidence_rate()`. |
|||
| 205 | -4x | +|||
| 7 | +
- "CAVGINTS", "Average Conc from T1 to T2 Norm by SA", "CAVGINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "192",+ #' |
|||
| 206 | -4x | +|||
| 8 | +
- "CAVGINTW", "Average Conc from T1 to T2 Norm by WT", "CAVGINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "193",+ #' @inheritParams argument_convention |
|||
| 207 | -4x | +|||
| 9 | +
- "CAVGS", "Average Conc Norm by SA", "CAVGS", "Plasma/Blood/Serum", "194",+ #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
|||
| 208 | -4x | +|||
| 10 | +
- "CAVGW", "Average Conc Norm by WT", "CAVGW", "Plasma/Blood/Serum", "195",+ #' for confidence interval type. |
|||
| 209 | -4x | +|||
| 11 | +
- "CHTMAX", "Concentration at Half Tmax", "CHTMAX", "Plasma/Blood/Serum", "196",+ #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default) |
|||
| 210 | -4x | +|||
| 12 | +
- "CLFOB", "Total CL Obs by F Norm by BMI", "CLFOB", "Plasma/Blood/Serum", "197",+ #' indicating time unit for data input. |
|||
| 211 | -4x | +|||
| 13 | +
- "CLFOD", "Total CL Obs by F Norm by Dose", "CLFOD", "Plasma/Blood/Serum", "198",+ #' @param num_pt_year (`numeric(1)`)\cr number of patient-years to use when calculating adverse event rates. |
|||
| 212 | -4x | +|||
| 14 | +
- "CLFOS", "Total CL Obs by F Norm by SA", "CLFOS", "Plasma/Blood/Serum", "199",+ #' |
|||
| 213 | -4x | +|||
| 15 | +
- "CLFOW", "Total CL Obs by F Norm by WT", "CLFOW", "Plasma/Blood/Serum", "200",+ #' @return A list of components with the same names as the arguments. |
|||
| 214 | -4x | +|||
| 16 | +
- "CLFPB", "Total CL Pred by F Norm by BMI", "CLFPB", "Plasma/Blood/Serum", "201",+ #' |
|||
| 215 | -4x | +|||
| 17 | +
- "CLFPD", "Total CL Pred by F Norm by Dose", "CLFPD", "Plasma/Blood/Serum", "202",+ #' @seealso [incidence_rate] |
|||
| 216 | -4x | +|||
| 18 | +
- "CLFPS", "Total CL Pred by F Norm by SA", "CLFPS", "Plasma/Blood/Serum", "203",+ #' |
|||
| 217 | -4x | +|||
| 19 | +
- "CLFPW", "Total CL Pred by F Norm by WT", "CLFPW", "Plasma/Blood/Serum", "204",+ #' @examples |
|||
| 218 | -4x | +|||
| 20 | +
- "CLFTAU", "Total CL by F for Dose Int", "CLFTAU", "Plasma/Blood/Serum", "205",+ #' control_incidence_rate(0.9, "exact", "month", 100) |
|||
| 219 | -4x | +|||
| 21 | +
- "CLFTAUB", "Total CL by F for Dose Int Norm by BMI", "CLFTAUB", "Plasma/Blood/Serum", "206",+ #' |
|||
| 220 | -4x | +|||
| 22 | +
- "CLFTAUD", "Total CL by F for Dose Int Norm by Dose", "CLFTAUD", "Plasma/Blood/Serum", "207",+ #' @export |
|||
| 221 | -4x | +|||
| 23 | +
- "CLFTAUS", "Total CL by F for Dose Int Norm by SA", "CLFTAUS", "Plasma/Blood/Serum", "208",+ control_incidence_rate <- function(conf_level = 0.95, |
|||
| 222 | -4x | +|||
| 24 | +
- "CLFTAUW", "Total CL by F for Dose Int Norm by WT", "CLFTAUW", "Plasma/Blood/Serum", "209",+ conf_type = c("normal", "normal_log", "exact", "byar"),
|
|||
| 223 | -4x | +|||
| 25 | +
- "CLFUB", "Apparent CL for Unbound Drug", "CLFUB", "Plasma/Blood/Serum", "210",+ input_time_unit = c("year", "day", "week", "month"),
|
|||
| 224 | -4x | +|||
| 26 | +
- "CLOB", "Total CL Obs Norm by BMI", "CLOB", "Plasma/Blood/Serum", "211",+ num_pt_year = 100) {
|
|||
| 225 | -4x | +27 | +14x |
- "CLOD", "Total CL Obs Norm by Dose", "CLOD", "Plasma/Blood/Serum", "212",+ conf_type <- match.arg(conf_type) |
| 226 | -4x | +28 | +13x |
- "CLOS", "Total CL Obs Norm by SA", "CLOS", "Plasma/Blood/Serum", "213",+ input_time_unit <- match.arg(input_time_unit) |
| 227 | -4x | +29 | +12x |
- "CLOUB", "Total CL Obs for Unbound Drug", "CLOUB", "Plasma/Blood/Serum", "214",+ checkmate::assert_number(num_pt_year) |
| 228 | -4x | +30 | +11x |
- "CLOW", "Total CL Obs Norm by WT", "CLOW", "Plasma/Blood/Serum", "215",+ assert_proportion_value(conf_level) |
| 229 | -4x | +|||
| 31 | +
- "CLPB", "Total CL Pred Norm by BMI", "CLPB", "Plasma/Blood/Serum", "216",+ |
|||
| 230 | -4x | +32 | +10x |
- "CLPD", "Total CL Pred Norm by Dose", "CLPD", "Plasma/Blood/Serum", "217",+ list( |
| 231 | -4x | +33 | +10x |
- "CLPS", "Total CL Pred Norm by SA", "CLPS", "Plasma/Blood/Serum", "218",+ conf_level = conf_level, |
| 232 | -4x | +34 | +10x |
- "CLPUB", "Total CL Pred for Unbound Drug", "CLPUB", "Plasma/Blood/Serum", "219",+ conf_type = conf_type, |
| 233 | -4x | +35 | +10x |
- "CLPW", "Total CL Pred Norm by WT", "CLPW", "Plasma/Blood/Serum", "220",+ input_time_unit = input_time_unit, |
| 234 | -4x | +36 | +10x |
- "CLRPCLEV", "Renal CL as Pct CL EV", "CLRPCLEV", "Urine", "221",+ num_pt_year = num_pt_year |
| 235 | -4x | +|||
| 37 | +
- "CLRPCLIV", "Renal CL as Pct CL IV", "CLRPCLIV", "Urine", "222",+ ) |
|||
| 236 | -4x | +|||
| 38 | +
- "CLSTB", "Last Nonzero Conc Norm by BMI", "CLSTB", "Plasma/Blood/Serum", "223",+ } |
|||
| 237 | -4x | +
| 1 | +
- "CLSTD", "Last Nonzero Conc Norm by Dose", "CLSTD", "Plasma/Blood/Serum", "224",+ #' Summarize variables in columns |
|||
| 238 | -4x | +|||
| 2 | +
- "CLSTS", "Last Nonzero Conc Norm by SA", "CLSTS", "Plasma/Blood/Serum", "225",+ #' |
|||
| 239 | -4x | +|||
| 3 | +
- "CLSTW", "Last Nonzero Conc Norm by WT", "CLSTW", "Plasma/Blood/Serum", "226",+ #' @description `r lifecycle::badge("stable")`
|
|||
| 240 | -4x | +|||
| 4 | +
- "CLTAU", "Total CL for Dose Int", "CLTAU", "Plasma/Blood/Serum", "227",+ #' |
|||
| 241 | -4x | +|||
| 5 | +
- "CLTAUB", "Total CL for Dose Int Norm by BMI", "CLTAUB", "Plasma/Blood/Serum", "228",+ #' The analyze function [summarize_colvars()] uses the statistics function [s_summary()] to analyze variables that are |
|||
| 242 | -4x | +|||
| 6 | +
- "CLTAUD", "Total CL for Dose Int Norm by Dose", "CLTAUD", "Plasma/Blood/Serum", "229",+ #' arranged in columns. The variables to analyze should be specified in the table layout via column splits (see |
|||
| 243 | -4x | +|||
| 7 | +
- "CLTAUS", "Total CL for Dose Int Norm by SA", "CLTAUS", "Plasma/Blood/Serum", "230",+ #' [rtables::split_cols_by()] and [rtables::split_cols_by_multivar()]) prior to using [summarize_colvars()]. |
|||
| 244 | -4x | +|||
| 8 | +
- "CLTAUW", "Total CL for Dose Int Norm by WT", "CLTAUW", "Plasma/Blood/Serum", "231",+ #' |
|||
| 245 | -4x | +|||
| 9 | +
- "CMAXB", "Max Conc Norm by BMI", "CMAX_B", "Plasma/Blood/Serum", "232",+ #' The function is a minimal wrapper for [rtables::analyze_colvars()], a function typically used to apply different |
|||
| 246 | -4x | +|||
| 10 | +
- "CMAXLN", "Max Conc LN Transformed", "CMAXLN", "Plasma/Blood/Serum", "233",+ #' analysis methods in rows for each column variable. To use the analysis methods as column labels, please refer to |
|||
| 247 | -4x | +|||
| 11 | +
- "CMAXS", "Max Conc Norm by SA", "CMAXS", "Plasma/Blood/Serum", "234",+ #' the [analyze_vars_in_cols()] function. |
|||
| 248 | -4x | +|||
| 12 | +
- "CMAXUB", "Max Conc, Unbound Drug", "CMAXUB", "Plasma/Blood/Serum", "235",+ #' |
|||
| 249 | -4x | +|||
| 13 | +
- "CMAXW", "Max Conc Norm by WT", "CMAXW", "Plasma/Blood/Serum", "236",+ #' @inheritParams argument_convention |
|||
| 250 | -4x | +|||
| 14 | +
- "CMINB", "Min Conc Norm by BMI", "CMINB", "Plasma/Blood/Serum", "237",+ #' @param ... arguments passed to [s_summary()]. |
|||
| 251 | -4x | +|||
| 15 | +
- "CMIND", "Min Conc Norm by Dose", "CMIND", "Plasma/Blood/Serum", "238",+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
|||
| 252 | -4x | +|||
| 16 | +
- "CMINS", "Min Conc Norm by SA", "CMINS", "Plasma/Blood/Serum", "239",+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 253 | -4x | +|||
| 17 | +
- "CMINW", "Min Conc Norm by WT", "CMINW", "Plasma/Blood/Serum", "240",+ #' for that statistic's row label. |
|||
| 254 | -4x | +|||
| 18 | +
- "CONC", "Concentration", "CONC", "Plasma/Blood/Serum", "241",+ #' |
|||
| 255 | -4x | +|||
| 19 | +
- "CONCB", "Conc by BMI", "CONCB", "Plasma/Blood/Serum", "242",+ #' @return |
|||
| 256 | -4x | +|||
| 20 | +
- "CONCD", "Conc by Dose", "CONCD", "Plasma/Blood/Serum", "243",+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
|||
| 257 | -4x | +|||
| 21 | +
- "CONCS", "Conc by SA", "CONCS", "Plasma/Blood/Serum", "244",+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
|||
| 258 | -4x | +|||
| 22 | +
- "CONCW", "Conc by WT", "CONCW", "Plasma/Blood/Serum", "245",+ #' in columns, and add it to the table layout. |
|||
| 259 | -4x | +|||
| 23 | +
- "CTROUGH", "Conc Trough", "CTROUGH", "Plasma/Blood/Serum", "246",+ #' |
|||
| 260 | -4x | +|||
| 24 | +
- "CTROUGHB", "Conc Trough by BMI", "CTROUGHB", "Plasma/Blood/Serum", "247",+ #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`]. |
|||
| 261 | -4x | +|||
| 25 | +
- "CTROUGHD", "Conc Trough by Dose", "CTROUGHD", "Plasma/Blood/Serum", "248",+ #' |
|||
| 262 | -4x | +|||
| 26 | +
- "CTROUGHS", "Conc Trough by SA", "CTROUGHS", "Plasma/Blood/Serum", "249",+ #' @examples |
|||
| 263 | -4x | +|||
| 27 | +
- "CTROUGHW", "Conc Trough by WT", "CTROUGHW", "Plasma/Blood/Serum", "250",+ #' dta_test <- data.frame( |
|||
| 264 | -4x | +|||
| 28 | +
- "EFFHL", "Effective Half-Life", "EFFHL", "Plasma/Blood/Serum", "251",+ #' USUBJID = rep(1:6, each = 3), |
|||
| 265 | -4x | +|||
| 29 | +
- "ERINT", "Excret Rate from T1 to T2", "ERINT_T1_T2_UNIT", "Plasma/Blood/Serum", "252",+ #' PARAMCD = rep("lab", 6 * 3),
+ |
+ |||
| 30 | ++ |
+ #' AVISIT = rep(paste0("V", 1:3), 6),
+ |
+ ||
| 31 | ++ |
+ #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ |
+ ||
| 32 | ++ |
+ #' AVAL = c(9:1, rep(NA, 9)),+ |
+ ||
| 33 | ++ |
+ #' CHG = c(1:9, rep(NA, 9))+ |
+ ||
| 34 | ++ |
+ #' )+ |
+ ||
| 35 | ++ |
+ #'+ |
+ ||
| 36 | ++ |
+ #' ## Default output within a `rtables` pipeline.+ |
+ ||
| 37 | ++ |
+ #' basic_table() %>%+ |
+ ||
| 38 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+ ||
| 39 | ++ |
+ #' split_rows_by("AVISIT") %>%
+ |
+ ||
| 40 | ++ |
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ |
+ ||
| 41 | ++ |
+ #' summarize_colvars() %>%+ |
+ ||
| 42 | ++ |
+ #' build_table(dta_test)+ |
+ ||
| 43 | ++ |
+ #'+ |
+ ||
| 44 | ++ |
+ #' ## Selection of statistics, formats and labels also work.+ |
+ ||
| 45 | ++ |
+ #' basic_table() %>%+ |
+ ||
| 46 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+ ||
| 47 | ++ |
+ #' split_rows_by("AVISIT") %>%
+ |
+ ||
| 48 | ++ |
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ |
+ ||
| 49 | ++ |
+ #' summarize_colvars(+ |
+ ||
| 50 | ++ |
+ #' .stats = c("n", "mean_sd"),
+ |
+ ||
| 51 | ++ |
+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ |
+ ||
| 52 | ++ |
+ #' .labels = c(n = "n", mean_sd = "Mean, SD")+ |
+ ||
| 53 | ++ |
+ #' ) %>%+ |
+ ||
| 54 | ++ |
+ #' build_table(dta_test)+ |
+ ||
| 55 | ++ |
+ #'+ |
+ ||
| 56 | ++ |
+ #' ## Use arguments interpreted by `s_summary`.+ |
+ ||
| 57 | ++ |
+ #' basic_table() %>%+ |
+ ||
| 58 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+ ||
| 59 | ++ |
+ #' split_rows_by("AVISIT") %>%
+ |
+ ||
| 60 | ++ |
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ |
+ ||
| 61 | ++ |
+ #' summarize_colvars(na.rm = FALSE) %>%+ |
+ ||
| 62 | ++ |
+ #' build_table(dta_test)+ |
+ ||
| 63 | ++ |
+ #'+ |
+ ||
| 64 | ++ |
+ #' @export+ |
+ ||
| 65 | ++ |
+ summarize_colvars <- function(lyt,+ |
+ ||
| 66 | ++ |
+ ...,+ |
+ ||
| 67 | ++ |
+ na_str = default_na_str(),+ |
+ ||
| 68 | ++ |
+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ |
+ ||
| 69 | ++ |
+ .formats = NULL,+ |
+ ||
| 70 | ++ |
+ .labels = NULL,+ |
+ ||
| 71 | ++ |
+ .indent_mods = NULL) {
|
||
| 266 | -4x | +72 | +3x |
- "ERINTB", "Excret Rate from T1 to T2 Norm by BMI", "ERINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "253",+ extra_args <- list(.stats = .stats, na_str = na_str, ...) |
| 267 | -4x | +73 | +1x |
- "ERINTD", "Excret Rate from T1 to T2 Norm by Dose", "ERINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "254",+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
| 268 | -4x | +74 | +1x |
- "ERINTS", "Excret Rate from T1 to T2 Norm by SA", "ERINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "255",+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
| 269 | -4x | +75 | +1x |
- "ERINTW", "Excret Rate from T1 to T2 Norm by WT", "ERINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "256",+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ |
+
| 76 | ++ | + | ||
| 270 | -4x | +77 | +3x |
- "ERLSTB", "Last Meas Excretion Rate Norm by BMI", "ERLSTB", "Plasma/Blood/Serum", "257",+ analyze_colvars( |
| 271 | -4x | +78 | +3x |
- "ERLSTD", "Last Meas Excretion Rate Norm by Dose", "ERLSTD", "Plasma/Blood/Serum", "258",+ lyt, |
| 272 | -4x | +79 | +3x |
- "ERLSTS", "Last Meas Excretion Rate Norm by SA", "ERLSTS", "Plasma/Blood/Serum", "259",+ afun = a_summary, |
| 273 | -4x | +80 | +3x |
- "ERLSTW", "Last Meas Excretion Rate Norm by WT", "ERLSTW", "Plasma/Blood/Serum", "260",+ na_str = na_str, |
| 274 | -4x | +81 | +3x |
- "ERMAXB", "Max Excretion Rate Norm by BMI", "ERMAXB", "Plasma/Blood/Serum", "261",+ extra_args = extra_args+ |
+
| 82 | ++ |
+ )+ |
+ ||
| 83 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Summarize change from baseline values or absolute baseline values+ |
+ ||
| 2 | ++ |
+ #'+ |
+ ||
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ ||
| 4 | ++ |
+ #'+ |
+ ||
| 5 | ++ |
+ #' The analyze function [summarize_change()] creates a layout element to summarize the change from baseline or absolute+ |
+ ||
| 6 | ++ |
+ #' baseline values. The primary analysis variable `vars` indicates the numerical change from baseline results.+ |
+ ||
| 7 | ++ |
+ #'+ |
+ ||
| 8 | ++ |
+ #' Required secondary analysis variables `value` and `baseline_flag` can be supplied to the function via+ |
+ ||
| 9 | ++ |
+ #' the `variables` argument. The `value` element should be the name of the analysis value variable, and the+ |
+ ||
| 10 | ++ |
+ #' `baseline_flag` element should be the name of the flag variable that indicates whether or not records contain+ |
+ ||
| 11 | ++ |
+ #' baseline values. Depending on the baseline flag given, either the absolute baseline values (at baseline)+ |
+ ||
| 12 | ++ |
+ #' or the change from baseline values (post-baseline) are then summarized.+ |
+ ||
| 13 | ++ |
+ #'+ |
+ ||
| 14 | ++ |
+ #' @inheritParams argument_convention+ |
+ ||
| 15 | ++ |
+ #' @param .stats (`character`)\cr statistics to select for the table.+ |
+ ||
| 16 | ++ |
+ #'+ |
+ ||
| 17 | ++ |
+ #' Options are: ``r shQuote(get_stats("analyze_vars_numeric"))``
+ |
+ ||
| 18 | ++ |
+ #'+ |
+ ||
| 19 | ++ |
+ #' @name summarize_change+ |
+ ||
| 20 | ++ |
+ #' @order 1+ |
+ ||
| 21 | ++ |
+ NULL+ |
+ ||
| 22 | ++ | + + | +||
| 23 | ++ |
+ #' @describeIn summarize_change Statistics function that summarizes baseline or post-baseline visits.+ |
+ ||
| 24 | ++ |
+ #'+ |
+ ||
| 25 | ++ |
+ #' @return+ |
+ ||
| 26 | ++ |
+ #' * `s_change_from_baseline()` returns the same values returned by [s_summary.numeric()].+ |
+ ||
| 27 | ++ |
+ #'+ |
+ ||
| 28 | ++ |
+ #' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise+ |
+ ||
| 29 | ++ |
+ #' an error will be thrown.+ |
+ ||
| 30 | ++ |
+ #'+ |
+ ||
| 31 | ++ |
+ #' @keywords internal+ |
+ ||
| 32 | ++ |
+ s_change_from_baseline <- function(df,+ |
+ ||
| 33 | ++ |
+ .var,+ |
+ ||
| 34 | ++ |
+ variables,+ |
+ ||
| 35 | ++ |
+ na.rm = TRUE, # nolint+ |
+ ||
| 36 | ++ |
+ ...) {
|
||
| 275 | +37 | 4x |
- "ERMAXD", "Max Excretion Rate Norm by Dose", "ERMAXD", "Plasma/Blood/Serum", "262",+ checkmate::assert_numeric(df[[variables$value]]) |
|
| 276 | +38 | 4x |
- "ERMAXS", "Max Excretion Rate Norm by SA", "ERMAXS", "Plasma/Blood/Serum", "263",+ checkmate::assert_numeric(df[[.var]]) |
|
| 277 | +39 | 4x |
- "ERMAXW", "Max Excretion Rate Norm by WT", "ERMAXW", "Plasma/Blood/Serum", "264",+ checkmate::assert_logical(df[[variables$baseline_flag]]) |
|
| 278 | +40 | 4x |
- "ERTLST", "Midpoint of Interval of Last Nonzero ER", "ERTLST", "Plasma/Blood/Serum", "265",+ checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1) |
|
| 279 | +41 | 4x |
- "FABS", "Absolute Bioavailability", "FABS", "Plasma/Blood/Serum", "266",+ assert_df_with_variables(df, c(variables, list(chg = .var)))+ |
+ |
| 42 | ++ | + | ||
| 280 | +43 | 4x |
- "FB", "Fraction Bound", "FB", "Plasma/Blood/Serum", "267",+ combined <- ifelse( |
|
| 281 | +44 | 4x |
- "FREL", "Relative Bioavailability", "FREL", "Plasma/Blood/Serum", "268",+ df[[variables$baseline_flag]], |
|
| 282 | +45 | 4x |
- "FREXINT", "Fract Excr from T1 to T2", "FREXINT_T1_T2_UNIT", "Plasma/Blood/Serum", "269",+ df[[variables$value]], |
|
| 283 | +46 | 4x |
- "FU", "Fraction Unbound", "FU", "Plasma/Blood/Serum", "270",+ df[[.var]]+ |
+ |
| 47 | ++ |
+ ) |
||
| 284 | +48 | 4x |
- "HDCL", "Hemodialysis Clearance", "HDCL", "Plasma/Blood/Serum", "271",+ if (is.logical(combined) && identical(length(combined), 0L)) {
|
|
| 285 | -4x | +49 | +1x |
- "HDER", "Hemodialysis Extraction Ratio", "HDER", "Plasma/Blood/Serum", "272",+ combined <- numeric(0)+ |
+
| 50 | ++ |
+ } |
||
| 286 | +51 | 4x |
- "HTMAX", "Half Tmax", "HTMAX", "Plasma/Blood/Serum", "273",+ s_summary(combined, na.rm = na.rm, ...)+ |
+ |
| 52 | ++ |
+ }+ |
+ ||
| 53 | ++ | + + | +||
| 54 | ++ |
+ #' @describeIn summarize_change Formatted analysis function which is used as `afun` in `summarize_change()`. |
||
| 287 | -4x | +|||
| 55 | +
- "LAMZLTAU", "Lambda z Lower Limit TAU", "LAMZLTAU", "Plasma/Blood/Serum", "274",+ #' |
|||
| 288 | -4x | +|||
| 56 | +
- "LAMZNTAU", "Number of Points for Lambda z TAU", "LAMZNTAU", "Plasma/Blood/Serum", "275",+ #' @return |
|||
| 289 | -4x | +|||
| 57 | +
- "LAMZSPN", "Lambda z Span", "LAMZSPN", "Plasma/Blood/Serum", "276",+ #' * `a_change_from_baseline()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 290 | -4x | +|||
| 58 | +
- "LAMZTAU", "Lambda z TAU", "LAMZTAU", "Plasma/Blood/Serum", "277",+ #' |
|||
| 291 | -4x | +|||
| 59 | +
- "LAMZUTAU", "Lambda z Upper Limit TAU", "LAMZUTAU", "Plasma/Blood/Serum", "278",+ #' @keywords internal |
|||
| 292 | -4x | +|||
| 60 | +
- "MAT", "Mean Absorption Time", "MAT", "Plasma/Blood/Serum", "279",+ a_change_from_baseline <- make_afun( |
|||
| 293 | -4x | +|||
| 61 | +
- "MRAUCIFO", "Metabolite Ratio for AUC Infinity Obs", "MRAUCIFO", "Plasma/Blood/Serum", "280",+ s_change_from_baseline, |
|||
| 294 | -4x | +|||
| 62 | +
- "MRAUCIFP", "Metabolite Ratio for AUC Infinity Pred", "MRAUCIFP", "Plasma/Blood/Serum", "281",+ .formats = c( |
|||
| 295 | -4x | +|||
| 63 | +
- "MRAUCINT", "Metabolite Ratio AUC from T1 to T2", "MRAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "282",+ n = "xx", |
|||
| 296 | -4x | +|||
| 64 | +
- "MRAUCLST", "Metabolite Ratio AUC Last Nonzero Conc", "MRAUCLST", "Plasma/Blood/Serum", "283",+ mean_sd = "xx.xx (xx.xx)", |
|||
| 297 | -4x | +|||
| 65 | +
- "MRAUCTAU", "Metabolite Ratio for AUC Dosing Interval", "MRAUCTAU", "Plasma/Blood/Serum", "284",+ mean_se = "xx.xx (xx.xx)", |
|||
| 298 | -4x | +|||
| 66 | +
- "MRCMAX", "Metabolite Ratio for Max Conc", "MRCMAX", "Plasma/Blood/Serum", "285",+ median = "xx.xx", |
|||
| 299 | -4x | +|||
| 67 | +
- "MRTEVIFO", "MRT Extravasc Infinity Obs", "MRTEVIFO", "Plasma/Blood/Serum", "286",+ range = "xx.xx - xx.xx", |
|||
| 300 | -4x | +|||
| 68 | +
- "MRTEVIFP", "MRT Extravasc Infinity Pred", "MRTEVIFP", "Plasma/Blood/Serum", "287",+ mean_ci = "(xx.xx, xx.xx)", |
|||
| 301 | -4x | +|||
| 69 | +
- "MRTEVLST", "MRT Extravasc to Last Nonzero Conc", "MRTEVLST", "Plasma/Blood/Serum", "288",+ median_ci = "(xx.xx, xx.xx)", |
|||
| 302 | -4x | +|||
| 70 | +
- "MRTIVIFO", "MRT Intravasc Infinity Obs", "MRTIVIFO", "Plasma/Blood/Serum", "289",+ mean_pval = "xx.xx" |
|||
| 303 | -4x | +|||
| 71 | +
- "MRTIVIFP", "MRT Intravasc Infinity Pred", "MRTIVIFP", "Plasma/Blood/Serum", "290",+ ), |
|||
| 304 | -4x | +|||
| 72 | +
- "MRTIVLST", "MRT Intravasc to Last Nonzero Conc", "MRTIVLST", "Plasma/Blood/Serum", "291",+ .labels = c( |
|||
| 305 | -4x | +|||
| 73 | +
- "NRENALCL", "Nonrenal CL", "NRENALCL", "Urine", "292",+ mean_sd = "Mean (SD)", |
|||
| 306 | -4x | +|||
| 74 | +
- "NRENLCLB", "Nonrenal CL Norm by BMI", "NRENLCLB", "Urine", "293",+ mean_se = "Mean (SE)", |
|||
| 307 | -4x | +|||
| 75 | +
- "NRENLCLD", "Nonrenal CL Norm by Dose", "NRENLCLD", "Urine", "294",+ median = "Median", |
|||
| 308 | -4x | +|||
| 76 | +
- "NRENLCLS", "Nonrenal CL Norm by SA", "NRENLCLS", "Urine", "295",+ range = "Min - Max" |
|||
| 309 | -4x | +|||
| 77 | +
- "NRENLCLW", "Nonrenal CL Norm by WT", "NRENLCLW", "Urine", "296",+ ) |
|||
| 310 | -4x | +|||
| 78 | +
- "PTROUGHR", "Peak Trough Ratio", "PTROUGHR", "Plasma/Blood/Serum", "297",+ ) |
|||
| 311 | -4x | +|||
| 79 | +
- "RAAUC", "Ratio AUC", "RAAUC", "Plasma/Blood/Serum", "298",+ |
|||
| 312 | -4x | +|||
| 80 | +
- "RAAUCIFO", "Ratio AUC Infinity Obs", "RAAUCIFO", "Plasma/Blood/Serum", "299",+ #' @describeIn summarize_change Layout-creating function which can take statistics function arguments |
|||
| 313 | -4x | +|||
| 81 | +
- "RAAUCIFP", "Ratio AUC Infinity Pred", "RAAUCIFP", "Plasma/Blood/Serum", "300",+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 314 | -4x | +|||
| 82 | +
- "RACMAX", "Ratio CMAX", "RACMAX", "Plasma/Blood/Serum", "301",+ #' |
|||
| 315 | -4x | +|||
| 83 | +
- "RAMAXMIN", "Ratio of CMAX to CMIN", "RAMAXMIN", "Plasma/Blood/Serum", "302",+ #' @return |
|||
| 316 | -4x | +|||
| 84 | +
- "RCAMIFO", "Amt Rec Infinity Obs", "RCAMIFO", "Plasma/Blood/Serum", "303",+ #' * `summarize_change()` returns a layout object suitable for passing to further layouting functions, |
|||
| 317 | -4x | +|||
| 85 | +
- "RCAMIFOB", "Amt Rec Infinity Obs Norm by BMI", "RCAMIFOB", "Plasma/Blood/Serum", "304",+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 318 | -4x | +|||
| 86 | +
- "RCAMIFOS", "Amt Rec Infinity Obs Norm by SA", "RCAMIFOS", "Plasma/Blood/Serum", "305",+ #' the statistics from `s_change_from_baseline()` to the table layout. |
|||
| 319 | -4x | +|||
| 87 | +
- "RCAMIFOW", "Amt Rec Infinity Obs Norm by WT", "RCAMIFOW", "Plasma/Blood/Serum", "306",+ #' |
|||
| 320 | -4x | +|||
| 88 | +
- "RCAMIFP", "Amt Rec Infinity Pred", "RCAMIFP", "Plasma/Blood/Serum", "307",+ #' @note To be used after a split on visits in the layout, such that each data subset only contains |
|||
| 321 | -4x | +|||
| 89 | +
- "RCAMIFPB", "Amt Rec Infinity Pred Norm by BMI", "RCAMIFPB", "Plasma/Blood/Serum", "308",+ #' either baseline or post-baseline data. |
|||
| 322 | -4x | +|||
| 90 | +
- "RCAMIFPS", "Amt Rec Infinity Pred Norm by SA", "RCAMIFPS", "Plasma/Blood/Serum", "309",+ #' |
|||
| 323 | -4x | +|||
| 91 | +
- "RCAMIFPW", "Amt Rec Infinity Pred Norm by WT", "RCAMIFPW", "Plasma/Blood/Serum", "310",+ #' @examples |
|||
| 324 | -4x | +|||
| 92 | +
- "RCAMINTB", "Amt Rec from T1 to T2 Norm by BMI", "RCAMINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "311",+ #' library(dplyr) |
|||
| 325 | -4x | +|||
| 93 | +
- "RCAMINTS", "Amt Rec from T1 to T2 Norm by SA", "RCAMINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "312",+ #' |
|||
| 326 | -4x | +|||
| 94 | +
- "RCAMINTW", "Amt Rec from T1 to T2 Norm by WT", "RCAMINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "313",+ #' ## Fabricate dataset |
|||
| 327 | -4x | +|||
| 95 | +
- "RCAMTAU", "Amt Rec Over Dosing Interval", "RCAMTAU", "Plasma/Blood/Serum", "314",+ #' dta_test <- data.frame( |
|||
| 328 | -4x | +|||
| 96 | +
- "RCAMTAUB", "Amt Rec Over Dosing Interval Norm by BMI", "RCAMTAUB", "Plasma/Blood/Serum", "315",+ #' USUBJID = rep(1:6, each = 3), |
|||
| 329 | -4x | +|||
| 97 | +
- "RCAMTAUS", "Amt Rec Over Dosing Interval Norm by SA", "RCAMTAUS", "Plasma/Blood/Serum", "316",+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
|||
| 330 | -4x | +|||
| 98 | +
- "RCAMTAUW", "Amt Rec Over Dosing Interval Norm by WT", "RCAMTAUW", "Plasma/Blood/Serum", "317",+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|||
| 331 | -4x | +|||
| 99 | +
- "RCPCIFO", "Pct Rec Infinity Obs", "RCPCIFO", "Plasma/Blood/Serum", "318",+ #' AVAL = c(9:1, rep(NA, 9)) |
|||
| 332 | -4x | +|||
| 100 | +
- "RCPCIFOB", "Pct Rec Infinity Obs Norm by BMI", "RCPCIFOB", "Plasma/Blood/Serum", "319",+ #' ) %>% |
|||
| 333 | -4x | +|||
| 101 | +
- "RCPCIFOS", "Pct Rec Infinity Obs Norm by SA", "RCPCIFOS", "Plasma/Blood/Serum", "320",+ #' mutate(ABLFLL = AVISIT == "V1") %>% |
|||
| 334 | -4x | +|||
| 102 | +
- "RCPCIFOW", "Pct Rec Infinity Obs Norm by WT", "RCPCIFOW", "Plasma/Blood/Serum", "321",+ #' group_by(USUBJID) %>% |
|||
| 335 | -4x | +|||
| 103 | +
- "RCPCIFP", "Pct Rec Infinity Pred", "RCPCIFP", "Plasma/Blood/Serum", "322",+ #' mutate( |
|||
| 336 | -4x | +|||
| 104 | +
- "RCPCIFPB", "Pct Rec Infinity Pred Norm by BMI", "RCPCIFPB", "Plasma/Blood/Serum", "323",+ #' BLVAL = AVAL[ABLFLL], |
|||
| 337 | -4x | +|||
| 105 | +
- "RCPCIFPS", "Pct Rec Infinity Pred Norm by SA", "RCPCIFPS", "Plasma/Blood/Serum", "324",+ #' CHG = AVAL - BLVAL |
|||
| 338 | -4x | +|||
| 106 | +
- "RCPCIFPW", "Pct Rec Infinity Pred Norm by WT", "RCPCIFPW", "Plasma/Blood/Serum", "325",+ #' ) %>% |
|||
| 339 | -4x | +|||
| 107 | +
- "RCPCINTB", "Pct Rec from T1 to T2 Norm by BMI", "RCPCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "326",+ #' ungroup() |
|||
| 340 | -4x | +|||
| 108 | +
- "RCPCINTS", "Pct Rec from T1 to T2 Norm by SA", "RCPCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "327",+ #' |
|||
| 341 | -4x | +|||
| 109 | +
- "RCPCINTW", "Pct Rec from T1 to T2 Norm by WT", "RCPCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "328",+ #' results <- basic_table() %>% |
|||
| 342 | -4x | +|||
| 110 | +
- "RCPCLST", "Pct Rec to Last Nonzero Conc", "RCPCLST", "Plasma/Blood/Serum", "329",+ #' split_cols_by("ARM") %>%
|
|||
| 343 | -4x | +|||
| 111 | +
- "RCPCTAU", "Pct Rec Over Dosing Interval", "RCPCTAU", "Plasma/Blood/Serum", "330",+ #' split_rows_by("AVISIT") %>%
|
|||
| 344 | -4x | +|||
| 112 | +
- "RCPCTAUB", "Pct Rec Over Dosing Interval Norm by BMI", "RCPCTAUB", "Plasma/Blood/Serum", "331",+ #' summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
|
|||
| 345 | -4x | +|||
| 113 | +
- "RCPCTAUS", "Pct Rec Over Dosing Interval Norm by SA", "RCPCTAUS", "Plasma/Blood/Serum", "332",+ #' build_table(dta_test) |
|||
| 346 | -4x | +|||
| 114 | +
- "RCPCTAUW", "Pct Rec Over Dosing Interval Norm by WT", "RCPCTAUW", "Plasma/Blood/Serum", "333",+ #' |
|||
| 347 | -4x | +|||
| 115 | +
- "RENALCLB", "Renal CL Norm by BMI", "RENALCLB", "Urine", "334",+ #' results |
|||
| 348 | -4x | +|||
| 116 | +
- "RENALCLD", "Renal CL Norm by Dose", "RENALCLD", "Urine", "335",+ #' |
|||
| 349 | -4x | +|||
| 117 | +
- "RENALCLS", "Renal CL Norm by SA", "RENALCLS", "Urine", "336",+ #' @export |
|||
| 350 | -4x | +|||
| 118 | +
- "RENALCLW", "Renal CL Norm by WT", "RENALCLW", "Urine", "337",+ #' @order 2 |
|||
| 351 | -4x | +|||
| 119 | +
- "RENCLTAU", "Renal CL for Dose Int", "RENCLTAU", "Urine", "338",+ summarize_change <- function(lyt, |
|||
| 352 | -4x | +|||
| 120 | +
- "RNCLINT", "Renal CL from T1 to T2", "RNCLINT_T1_T2_UNIT", "Urine", "339",+ vars, |
|||
| 353 | -4x | +|||
| 121 | +
- "RNCLINTB", "Renal CL from T1 to T2 Norm by BMI", "RNCLINTB_T1_T2_UNIT", "Urine", "340",+ variables, |
|||
| 354 | -4x | +|||
| 122 | +
- "RNCLINTD", "Renal CL from T1 to T2 Norm by Dose", "RNCLINTD_T1_T2_UNIT", "Urine", "341",+ na_str = default_na_str(), |
|||
| 355 | -4x | +|||
| 123 | +
- "RNCLINTS", "Renal CL from T1 to T2 Norm by SA", "RNCLINTS_T1_T2_UNIT", "Urine", "342",+ nested = TRUE, |
|||
| 356 | -4x | +|||
| 124 | +
- "RNCLINTW", "Renal CL from T1 to T2 Norm by WT", "RNCLINTW_T1_T2_UNIT", "Urine", "343",+ ..., |
|||
| 357 | -4x | +|||
| 125 | +
- "RNCLTAUB", "Renal CL for Dose Int Norm by BMI", "RNCLTAUB", "Urine", "344",+ table_names = vars, |
|||
| 358 | -4x | +|||
| 126 | +
- "RNCLTAUD", "Renal CL for Dose Int Norm by Dose", "RNCLTAUD", "Urine", "345",+ .stats = c("n", "mean_sd", "median", "range"),
|
|||
| 359 | -4x | +|||
| 127 | +
- "RNCLTAUS", "Renal CL for Dose Int Norm by SA", "RNCLTAUS", "Urine", "346",+ .formats = NULL, |
|||
| 360 | -4x | +|||
| 128 | +
- "RNCLTAUW", "Renal CL for Dose Int Norm by WT", "RNCLTAUW", "Urine", "347",+ .labels = NULL, |
|||
| 361 | -4x | +|||
| 129 | +
- "RNCLUB", "Renal CL for Unbound Drug", "RNCLUB", "Urine", "348",+ .indent_mods = NULL) {
|
|||
| 362 | -4x | +130 | +1x |
- "SRAUC", "Stationarity Ratio AUC", "SRAUC", "Plasma/Blood/Serum", "349",+ extra_args <- list(variables = variables, ...) |
| 363 | -4x | +|||
| 131 | +
- "SWING", "Swing", "SWING", "Plasma/Blood/Serum", "350",+ |
|||
| 364 | -4x | +132 | +1x |
- "TAUHL", "Half-Life TAU", "TAUHL", "Plasma/Blood/Serum", "351",+ afun <- make_afun( |
| 365 | -4x | +133 | +1x |
- "TBBL", "Time Below Baseline", "Time_Below_B", "Plasma/Blood/Serum", "352",+ a_change_from_baseline, |
| 366 | -4x | +134 | +1x |
- "TROUGHPR", "Trough Peak Ratio", "TROUGHPR", "Plasma/Blood/Serum", "353",+ .stats = .stats, |
| 367 | -4x | +135 | +1x |
- "V0", "Vol Dist Initial", "V0", "Plasma/Blood/Serum", "354",+ .formats = .formats, |
| 368 | -4x | +136 | +1x |
- "V0B", "Vol Dist Initial Norm by BMI", "V0B", "Plasma/Blood/Serum", "355",+ .labels = .labels, |
| 369 | -4x | +137 | +1x |
- "V0D", "Vol Dist Initial Norm by Dose", "V0D", "Plasma/Blood/Serum", "356",+ .indent_mods = .indent_mods |
| 370 | -4x | +|||
| 138 | +
- "V0S", "Vol Dist Initial Norm by SA", "V0S", "Plasma/Blood/Serum", "357",+ ) |
|||
| 371 | -4x | +|||
| 139 | +
- "V0W", "Vol Dist Initial Norm by WT", "V0W", "Plasma/Blood/Serum", "358",+ |
|||
| 372 | -4x | +140 | +1x |
- "VSSOB", "Vol Dist Steady State Obs Norm by BMI", "VSSOB", "Plasma/Blood/Serum", "359",+ analyze( |
| 373 | -4x | +141 | +1x |
- "VSSOBD", "Vol Dist Steady State Obs by B", "VSSOBD", "Plasma/Blood/Serum", "360",+ lyt, |
| 374 | -4x | +142 | +1x |
- "VSSOD", "Vol Dist Steady State Obs Norm by Dose", "VSSOD", "Plasma/Blood/Serum", "361",+ vars, |
| 375 | -4x | +143 | +1x |
- "VSSOF", "Vol Dist Steady State Obs by F", "VSSOF", "Plasma/Blood/Serum", "362",+ afun = afun, |
| 376 | -4x | +144 | +1x |
- "VSSOS", "Vol Dist Steady State Obs Norm by SA", "VSSOS", "Plasma/Blood/Serum", "363",+ na_str = na_str, |
| 377 | -4x | +145 | +1x |
- "VSSOUB", "Vol Dist Steady State Obs by UB", "VSSOUB", "Plasma/Blood/Serum", "364",+ nested = nested, |
| 378 | -4x | +146 | +1x |
- "VSSOW", "Vol Dist Steady State Obs Norm by WT", "VSSOW", "Plasma/Blood/Serum", "365",+ extra_args = extra_args, |
| 379 | -4x | +147 | +1x |
- "VSSPB", "Vol Dist Steady State Pred Norm by BMI", "VSSPB", "Plasma/Blood/Serum", "366",+ table_names = table_names |
| 380 | -4x | +|||
| 148 | +
- "VSSPBD", "Vol Dist Steady State Pred by B", "VSSPBD", "Plasma/Blood/Serum", "367",+ ) |
|||
| 381 | -4x | +|||
| 149 | +
- "VSSPD", "Vol Dist Steady State Pred Norm by Dose", "VSSPD", "Plasma/Blood/Serum", "368",+ } |
|||
| 382 | -4x | +
| 1 | +
- "VSSPF", "Vol Dist Steady State Pred by F", "VSSPF", "Plasma/Blood/Serum", "369",+ #' Control function for logistic regression model fitting |
|||
| 383 | -4x | +|||
| 2 | +
- "VSSPS", "Vol Dist Steady State Pred Norm by SA", "VSSPS", "Plasma/Blood/Serum", "370",+ #' |
|||
| 384 | -4x | +|||
| 3 | +
- "VSSPUB", "Vol Dist Steady State Pred by UB", "VSSPUB", "Plasma/Blood/Serum", "371",+ #' @description `r lifecycle::badge("stable")`
|
|||
| 385 | -4x | +|||
| 4 | +
- "VSSPW", "Vol Dist Steady State Pred Norm by WT", "VSSPW", "Plasma/Blood/Serum", "372",+ #' |
|||
| 386 | -4x | +|||
| 5 | +
- "VZ", "Vol Z", "Vz", "Plasma/Blood/Serum", "373",+ #' This is an auxiliary function for controlling arguments for logistic regression models. |
|||
| 387 | -4x | +|||
| 6 | +
- "VZF", "Vol Z by F", "Vz_F", "Plasma/Blood/Serum", "374",+ #' `conf_level` refers to the confidence level used for the Odds Ratio CIs. |
|||
| 388 | -4x | +|||
| 7 | +
- "VZFOB", "Vz Obs by F Norm by BMI", "VZFOB", "Plasma/Blood/Serum", "375",+ #' |
|||
| 389 | -4x | +|||
| 8 | +
- "VZFOD", "Vz Obs by F Norm by Dose", "VZFOD", "Plasma/Blood/Serum", "376",+ #' @inheritParams argument_convention |
|||
| 390 | -4x | +|||
| 9 | +
- "VZFOS", "Vz Obs by F Norm by SA", "VZFOS", "Plasma/Blood/Serum", "377",+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
|||
| 391 | -4x | +|||
| 10 | +
- "VZFOUB", "Vz Obs by F for UB", "VZFOUB", "Plasma/Blood/Serum", "378",+ #' This will be used when fitting the logistic regression model on the left hand side of the formula. |
|||
| 392 | -4x | +|||
| 11 | +
- "VZFOW", "Vz Obs by F Norm by WT", "VZFOW", "Plasma/Blood/Serum", "379",+ #' Note that the evaluated expression should result in either a logical vector or a factor with 2 |
|||
| 393 | -4x | +|||
| 12 | +
- "VZFPB", "Vz Pred by F Norm by BMI", "VZFPB", "Plasma/Blood/Serum", "380",+ #' levels. By default this is just `"response"` such that the original response variable is used |
|||
| 394 | -4x | +|||
| 13 | +
- "VZFPD", "Vz Pred by F Norm by Dose", "VZFPD", "Plasma/Blood/Serum", "381",+ #' and not modified further. |
|||
| 395 | -4x | +|||
| 14 | +
- "VZFPS", "Vz Pred by F Norm by SA", "VZFPS", "Plasma/Blood/Serum", "382",+ #' |
|||
| 396 | -4x | +|||
| 15 | +
- "VZFPUB", "Vz Pred by F for UB", "VZFPUB", "Plasma/Blood/Serum", "383",+ #' @return A list of components with the same names as the arguments. |
|||
| 397 | -4x | +|||
| 16 | +
- "VZFPW", "Vz Pred by F Norm by WT", "VZFPW", "Plasma/Blood/Serum", "384",+ #' |
|||
| 398 | -4x | +|||
| 17 | +
- "VZFTAU", "Vz for Dose Int by F", "VZFTAU", "Plasma/Blood/Serum", "385",+ #' @examples |
|||
| 399 | -4x | +|||
| 18 | +
- "VZFTAUB", "Vz for Dose Int by F Norm by BMI", "VZFTAUB", "Plasma/Blood/Serum", "386",+ #' # Standard options. |
|||
| 400 | -4x | +|||
| 19 | +
- "VZFTAUD", "Vz for Dose Int by F Norm by Dose", "VZFTAUD", "Plasma/Blood/Serum", "387",+ #' control_logistic() |
|||
| 401 | -4x | +|||
| 20 | +
- "VZFTAUS", "Vz for Dose Int by F Norm by SA", "VZFTAUS", "Plasma/Blood/Serum", "388",+ #' |
|||
| 402 | -4x | +|||
| 21 | +
- "VZFTAUW", "Vz for Dose Int by F Norm by WT", "VZFTAUW", "Plasma/Blood/Serum", "389",+ #' # Modify confidence level. |
|||
| 403 | -4x | +|||
| 22 | +
- "VZOB", "Vz Obs Norm by BMI", "VZOB", "Plasma/Blood/Serum", "390",+ #' control_logistic(conf_level = 0.9) |
|||
| 404 | -4x | +|||
| 23 | +
- "VZOD", "Vz Obs Norm by Dose", "VZOD", "Plasma/Blood/Serum", "391",+ #' |
|||
| 405 | -4x | +|||
| 24 | +
- "VZOS", "Vz Obs Norm by SA", "VZOS", "Plasma/Blood/Serum", "392",+ #' # Use a different response definition. |
|||
| 406 | -4x | +|||
| 25 | +
- "VZOUB", "Vz Obs for UB", "VZOUB", "Plasma/Blood/Serum", "393",+ #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
|
|||
| 407 | -4x | +|||
| 26 | +
- "VZOW", "Vz Obs Norm by WT", "VZOW", "Plasma/Blood/Serum", "394",+ #' |
|||
| 408 | -4x | +|||
| 27 | +
- "VZPB", "Vz Pred Norm by BMI", "VZPB", "Plasma/Blood/Serum", "395",+ #' @export |
|||
| 409 | -4x | +|||
| 28 | +
- "VZPD", "Vz Pred Norm by Dose", "VZPD", "Plasma/Blood/Serum", "396",+ control_logistic <- function(response_definition = "response", |
|||
| 410 | -4x | +|||
| 29 | +
- "VZPS", "Vz Pred Norm by SA", "VZPS", "Plasma/Blood/Serum", "397",+ conf_level = 0.95) {
|
|||
| 411 | -4x | +30 | +29x |
- "VZPUB", "Vz Pred for UB", "VZPUB", "Plasma/Blood/Serum", "398"+ checkmate::assert_true(grepl("response", response_definition))
|
| 412 | -+ | |||
| 31 | +28x |
- ),+ checkmate::assert_string(response_definition) |
||
| 413 | -4x | +32 | +28x |
- ncol = 5,+ assert_proportion_value(conf_level) |
| 414 | -4x | +33 | +27x |
- byrow = TRUE+ list( |
| 415 | -+ | |||
| 34 | +27x |
- ))+ response_definition = response_definition, |
||
| 416 | -4x | +35 | +27x |
- colnames(pk_dataset) <- c("PARAMCD", "PARAM", "TLG_DISPLAY", "MATRIX", "TLG_ORDER")
+ conf_level = conf_level |
| 417 | -4x | +|||
| 36 | +
- pk_dataset+ ) |
|||
| 418 | +37 |
} |